C******************** START FILE SPLINE.FOR ; GROUP TRKRLIB ******************
CC
CCCCCCCCCCCCCCCC
C	THE CODES (SPLINE & SEVAL) ARE TAKEN FROM:
C	FORSYTHE,MALCOLM AND MOLER, "COMPUTER METHODS FOR
C	MATHEMATICAL COMPUTATIONS",PRENTICE-HALL, 1977.
C
C	THE CODES (SPLEEN,SPLAAN & SPEVAL) ARE ADAPTATIONS
C	BY R.M. WIELAND FOR SPECIAL CASES ... SEE COMMENTS

      SUBROUTINE SPLINE_ez1 (N, X, Y, B, C, D)
      INTEGER N
      REAL X(N), Y(N), B(N), C(N), D(N)
C
C  THE COEFFICIENTS B(I), C(I), AND D(I), I=1,2,...,N ARE COMPUTED
C  FOR A CUBIC INTERPOLATING SPLINE
C
C    S(X) = Y(I) + B(I)*(X-X(I)) + C(I)*(X-X(I))**2 + D(I)*(X-X(I))**3
C
C    FOR  X(I) .LE. X .LE. X(I+1)
C
C  INPUT..
C
C    N = THE NUMBER OF DATA POINTS OR KNOTS (N.GE.2)
C    X = THE ABSCISSAS OF THE KNOTS IN STRICTLY INCREASING ORDER
C    Y = THE ORDINATES OF THE KNOTS
C
C  OUTPUT..
C
C    B, C, D  = ARRAYS OF SPLINE COEFFICIENTS AS DEFINED ABOVE.
C
C  USING  P  TO DENOTE DIFFERENTIATION,
C
C    Y(I) = S(X(I))
C    B(I) = SP(X(I))
C    C(I) = SPP(X(I))/2
C    D(I) = SPPP(X(I))/6  (DERIVATIVE FROM THE RIGHT)
C
CCCCCCCCCCCCCCC
C  THE ACCOMPANYING FUNCTION SUBPROGRAM  SEVAL  CAN BE USED
C  TO EVALUATE THE SPLINE.
C
C
      INTEGER NM1, IB, I
      REAL T
C
      NM1 = N-1
      IF ( N .LT. 2 ) RETURN
C
C
C DMC - CHECK ORDINATES
      DO 5 I=1,NM1
        IP1=I+1
        IF(X(IP1).LE.X(I)) then
             write(6,9000)
             write(6,9001) (x(ii),ii=1,N)
             zbomb=sqrt(-1.0/(x(1)*x(1)))
             write(6,*) zbomb
             write(6,*) ' spline.for: code will stop.'
             call exit(1)
 9000        FORMAT(/
     >' ? UNORDERED ORDINATE ARRAY PASSED TO SPLINE SUBROUTINE:')
 9001        FORMAT(1X,5(1X,1PE12.5))
        endif
 5    CONTINUE
C
      IF ( N .LT. 3 ) GO TO 50
C
C  SET UP TRIDIAGONAL SYSTEM
C
C  B = DIAGONAL, D = OFFDIAGONAL, C = RIGHT HAND SIDE.
C
      D(1) = X(2) - X(1)
      C(2) = (Y(2) - Y(1))/D(1)
      DO 10 I = 2, NM1
         D(I) = X(I+1) - X(I)
         B(I) = 2.*(D(I-1) + D(I))
         C(I+1) = (Y(I+1) - Y(I))/D(I)
         C(I) = C(I+1) - C(I)
   10 CONTINUE
C
C  END CONDITIONS.  THIRD DERIVATIVES AT  X(1)  AND  X(N)
C  OBTAINED FROM DIVIDED DIFFERENCES
C
      B(1) = -D(1)
      B(N) = -D(N-1)
      C(1) = 0.
      C(N) = 0.
      IF ( N .EQ. 3 ) GO TO 15
      C(1) = C(3)/(X(4)-X(2)) - C(2)/(X(3)-X(1))
      C(N) = C(N-1)/(X(N)-X(N-2)) - C(N-2)/(X(N-1)-X(N-3))
      C(1) = C(1)*D(1)**2/(X(4)-X(1))
      C(N) = -C(N)*D(N-1)**2/(X(N)-X(N-3))
C
C  FORWARD ELIMINATION
C
   15 DO 20 I = 2, N
         T = D(I-1)/B(I-1)
         B(I) = B(I) - T*D(I-1)
         C(I) = C(I) - T*C(I-1)
   20 CONTINUE
C
C  BACK SUBSTITUTION
C
      C(N) = C(N)/B(N)
      DO 30 IB = 1, NM1
         I = N-IB
         C(I) = (C(I) - D(I)*C(I+1))/B(I)
   30 CONTINUE
C
C  C(I) IS NOW THE SIGMA(I) OF THE TEXT
C
C  COMPUTE POLYNOMIAL COEFFICIENTS
C
      B(N) = (Y(N) - Y(NM1))/D(NM1) + D(NM1)*(C(NM1) + 2.*C(N))
      DO 40 I = 1, NM1
         B(I) = (Y(I+1) - Y(I))/D(I) - D(I)*(C(I+1) + 2.*C(I))
         D(I) = (C(I+1) - C(I))/D(I)
         C(I) = 3.*C(I)
   40 CONTINUE
      C(N) = 3.*C(N)
      D(N) = D(N-1)
      RETURN
C
   50 B(1) = (Y(2)-Y(1))/(X(2)-X(1))
      C(1) = 0.
      D(1) = 0.
      B(2) = B(1)
      C(2) = 0.
      D(2) = 0.
      RETURN
      END
C******************** END FILE SPLINE.FOR ; GROUP TRKRLIB ******************


! Name: Anantha Rao
! Reg no: 20181044
! This program provides the Improved Euler Method to solve the differential equation y' = f(x,y)

program modifiedeulermethod
      implicit none
      real*8:: x,y,y1, xwant, h, fxy, fxy1
      integer:: niter, i

      x= 0.0; y=0.0; h=0.001; xwant=1.57
      niter= int((xwant-x)/h)
      open(unit=21, file="modified_euler_method.dat")

      do i=1,niter
      fxy = 1+y**2
      y1 = y + (h/2)*fxy
      fxy1 = 1 + y1**2
      y = y + h*fxy1

      write(21,*) dfloat(i)*h, y
      end do
end program modifiedeulermethod


C
C	$Id$
C
      SUBROUTINE CSINTRSC (P1,P2,CN, P,IER)
      INTEGER IER
      DOUBLE PRECISION P1(3), P2(3), CN(3), P(3)
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/19/90
C
C   Given a great circle C and points P1 and P2 defining an
C arc A on the surface of the unit sphere, where A is the
C shorter of the two portions of the great circle C12 assoc-
C iated with P1 and P2, this subroutine returns the point
C of intersection P between C and C12 that is closer to A.
C Thus, if P1 and P2 lie in opposite hemispheres defined by
C C, P is the point of intersection of C with A.
C
C
C On input:
C
C       P1,P2 = Arrays of length 3 containing the Cartesian
C               coordinates of unit vectors.
C
C       CN = Array of length 3 containing the Cartesian
C            coordinates of a nonzero vector which defines C
C            as the intersection of the plane whose normal
C            is CN with the unit sphere.  Thus, if C is to
C            be the great circle defined by P and Q, CN
C            should be P X Q.
C
C The above parameters are not altered by this routine.
C
C       P = Array of length 3.
C
C On output:
C
C       P = Point of intersection defined above unless IER
C           .NE. 0, in which case P is not altered.
C
C       IER = Error indicator.
C             IER = 0 if no errors were encountered.
C             IER = 1 if <CN,P1> = <CN,P2>.  This occurs
C                     iff P1 = P2 or CN = 0 or there are
C                     two intersection points at the same
C                     distance from A.
C             IER = 2 if P2 = -P1 and the definition of A is
C                     therefore ambiguous.
C
C Modules required by CSINTRSC:  None
C
C Intrinsic function called by CSINTRSC:  SQRT
C
C***********************************************************
C
      INTEGER I
      DOUBLE PRECISION D1, D2, PP(3), PPN, T
C
C Local parameters:
C
C D1 =  <CN,P1>
C D2 =  <CN,P2>
C I =   DO-loop index
C PP =  P1 + T*(P2-P1) = Parametric representation of the
C         line defined by P1 and P2
C PPN = Norm of PP
C T =   D1/(D1-D2) = Parameter value chosen so that PP lies
C         in the plane of C
C
      D1 = CN(1)*P1(1) + CN(2)*P1(2) + CN(3)*P1(3)
      D2 = CN(1)*P2(1) + CN(2)*P2(2) + CN(3)*P2(3)
C
      IF (D1 .EQ. D2) THEN
        IER = 1
        RETURN
      ENDIF
C
C Solve for T such that <PP,CN> = 0 and compute PP and PPN.
C
      T = D1/(D1-D2)
      PPN = 0.D0
      DO 1 I = 1,3
        PP(I) = P1(I) + T*(P2(I)-P1(I))
        PPN = PPN + PP(I)*PP(I)
    1   CONTINUE
C
C PPN = 0 iff PP = 0 iff P2 = -P1 (and T = .5).
C
      IF (PPN .EQ. 0.D0) THEN
        IER = 2
        RETURN
      ENDIF
      PPN = SQRT(PPN)
C
C Compute P = PP/PPN.
C
      DO 2 I = 1,3
        P(I) = PP(I)/PPN
    2   CONTINUE
      IER = 0
      RETURN
      END


    Program zunmhr_example

!     ZUNMHR 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 blas_interfaces, Only: dznrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zgehrd, zhsein, zhseqr, zunmhr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Real (Kind=dp) :: thresh
      Integer :: i, ifail, info, k, lda, ldc, ldh, ldvl, ldz, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), c(:, :), h(:, :), tau(:), &
        vl(:, :), w(:), work(:), z(:, :)
      Real (Kind=dp), Allocatable :: rwork(:)
      Integer, Allocatable :: ifaill(:), ifailr(:)
      Logical, Allocatable :: select(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, aimag, conjg, maxloc, real
!     .. Executable Statements ..
      Write (nout, *) 'ZUNMHR Example Program Results'
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = 1
      lda = n
      ldc = n
      ldh = n
      ldvl = n
      lwork = 64*n
      Allocate (a(lda,n), c(ldc,n), h(ldh,n), tau(n), vl(ldvl,n), w(n), &
        work(lwork), z(ldz,1), rwork(n), ifaill(n), ifailr(n), select(n))

!     Read A from data file
      Read (nin, *)(a(i,1:n), i=1, n)

      Read (nin, *) thresh

!     Reduce A to upper Hessenberg form H = (Q**H)*A*Q
      Call zgehrd(n, 1, n, a, lda, tau, work, lwork, info)

!     Copy A to H
      h(1:n, 1:n) = a(1:n, 1:n)

!     Calculate the eigenvalues of H (same as A)
      Call zhseqr('Eigenvalues', 'No vectors', n, 1, n, h, ldh, w, z, ldz, &
        work, lwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100)(' (', real(w(i)), ',', aimag(w(i)), ')', i=1, n)
        Flush (nout)

        Do i = 1, n
          select(i) = real(w(i)) < thresh
        End Do

!       Calculate the eigenvectors of H (as specified by SELECT),
!       storing the result in C
        Call zhsein('Right', 'QR', 'No initial vectors', select, n, a, lda, w, &
          vl, ldvl, c, ldc, n, m, work, rwork, ifaill, ifailr, info)

!       Calculate the eigenvectors of A = Q * (eigenvectors of H)
        Call zunmhr('Left', 'No transpose', n, m, 1, n, a, lda, tau, c, ldc, &
          work, lwork, info)

!       Print eigenvectors

        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors, largest element real
        Do i = 1, m
          rwork(1:n) = abs(c(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(c(k,i))/abs(c(k,i))/dznrm2(n, c(1,i), 1)
          c(1:n, i) = c(1:n, i)*scal
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, m, c, &
          ldc, 'Bracketed', 'F7.4', 'Contents of array C', 'Integer', rlabs, &
          'Integer', clabs, 80, 0, ifail)

      End If

100   Format ((3X,4(A,F7.4,A,F7.4,A,:)))
    End Program


SUBROUTINE LINEQU(X1, Y1, X2, Y2, A, B, C)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE kind_param, ONLY:  DOUBLE
!-----------------------------------------------------------------------------
!
!   CALCULATES COEFFICIENTS A, B AND C OF
!   THE EQUATION OF THE LINE: A*X + B*Y = C
!   PASSING THROUGH THE POINTS (X1,Y1) AND (X2,Y2)
!
!-----------------------------------------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
  REAL(DOUBLE) , INTENT(IN) :: X1
  REAL(DOUBLE) , INTENT(IN) :: Y1
  REAL(DOUBLE) , INTENT(IN) :: X2
  REAL(DOUBLE) , INTENT(IN) :: Y2
  REAL(DOUBLE) , INTENT(INOUT) :: A
  REAL(DOUBLE) , INTENT(OUT) :: B
  REAL(DOUBLE) , INTENT(OUT) :: C
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------

  IF (X1 /= X2) THEN
     A = (Y1 - Y2)/(X2 - X1)
     B = 1.D0
     C = A*X1 + Y1
  ELSE
     A = 1.D0
     B = 0.D0
     C = X1
  ENDIF
  RETURN
END SUBROUTINE LINEQU


MODULE BOGO
IMPLICIT NONE
CONTAINS
  FUNCTION Sorted(a)
    LOGICAL :: Sorted
    INTEGER, INTENT(IN) :: a(:)
    INTEGER :: i

    Sorted = .TRUE.
    DO i = 1, SIZE(a)-1
      IF(a(i) > a(i+1)) THEN
        Sorted = .FALSE.
        EXIT
      END IF
    END DO
  END FUNCTION Sorted

  SUBROUTINE SHUFFLE(a)
    INTEGER, INTENT(IN OUT) :: a(:)
    INTEGER :: i, rand, temp
    REAL :: x

    DO i = SIZE(a), 1, -1
       CALL RANDOM_NUMBER(x)
       rand = INT(x * i) + 1
       temp = a(rand)
       a(rand) = a(i)
       a(i) = temp
    END DO
  END SUBROUTINE
END MODULE

PROGRAM BOGOSORT

  USE BOGO
  IMPLICIT NONE
  INTEGER :: iter = 0
  INTEGER :: array(8) = (/2, 7, 5, 3, 4, 8, 6, 1/)
  LOGICAL :: s

  DO
    s = Sorted(array)
    IF (s) EXIT
    CALL SHUFFLE(array)
    iter = iter + 1
  END DO
  WRITE (*,*) "Array required", iter, " shuffles to sort"

END PROGRAM BOGOSORT


      program add
      INTEGER SIZE
      PARAMETER (SIZE=100)
      real a(size,size), b(size,size), c(size,size)

      do 100 i = 1, size
         do 200 j = 1, size
            b(i,j) = (i-1)*size+(j-1)
            c(i,j) = b(i,j)/(size*size)
 200     continue
 100  continue

      do 300 i = 1, size
         do 400 j = 1, size
            a(i,j) = b(i,j) + c(i,j)
 400     continue
 300  continue

      end


program line_test
    use types_mod, only : sp
    use line_mod
    implicit none
    integer, parameter :: nr_points = 5
    real(kind=sp), dimension(nr_points) :: x, y, y_exp
    logical, dimension(nr_points) :: is_on_line
    integer :: i

    x = [(real(i, kind=sp), i = -2, 2)]
    y = [2.0_sp, 2.5_sp, 3.001_sp, 3.5_sp, 4.0_sp]
    y_exp = line(x)
    is_on_line = on_line(x, y)
    print '(A, E10.2)', 'epsilon = ', get_epsilon()
    do i = 1, nr_points
        print '(3F10.4, L10)', x(i), y(i), y_exp(i), is_on_line(i)
    end do
    if (all(is_on_line)) print '(A)', '# all on line'
    if (any(is_on_line)) print '(A)', '# some on line'

    call set_epsilon(1.0e-2_sp)
    is_on_line = on_line(x, y)
    print '(A, E10.2)', 'epsilon = ', get_epsilon()
    do i = 1, nr_points
        print '(3F10.4, L10)', x(i), y(i), y_exp(i), is_on_line(i)
    end do
    if (all(is_on_line)) print '(A)', '# all on line'
    if (any(is_on_line)) print '(A)', '# some on line'

end program line_test


! f-wave Riemann solver for the variable speed limit LWR traffic model

! q_t + (u_max(x,t) q(1-q))_x = 0

! Here the speed limit u_max (stored in aux(1,i) may vary with x and t.

! This solver seems to be less accurate that rp1_traffic_vc.f90, which does
! not use f-waves.  This solver also exhibits a one-cell entropy glitch
! for transonic rarefaction.  The other solver is the preferred default;
! this f-wave solver is left here mainly for educational purposes.

! waves: 1
! equations: 1
! aux fields: 1

! Conserved quantities:
!       1 q

! Auxiliary variables:
!       1 u_max

! See http://www.clawpack.org/riemann.html for a detailed explanation
! of the Riemann solver API.

subroutine rp1(maxm,num_eqn,num_waves,num_aux,num_ghost,num_cells, &
               ql,qr,auxl,auxr,fwave,s,amdq,apdq)
    implicit none
    ! Inputs
    integer, intent(in) :: maxm, num_eqn, num_waves, num_aux, num_ghost, num_cells
    double precision, intent(in), dimension(num_eqn, 1-num_ghost:maxm+num_ghost) :: ql,qr
    double precision, intent(in), dimension(num_aux, 1-num_ghost:maxm+num_ghost) :: auxl,auxr
    ! Outputs
    double precision, intent(out) :: s(num_waves,1-num_ghost:num_cells+num_ghost)
    double precision, intent(out) :: fwave(num_eqn,num_waves,1-num_ghost:num_cells+num_ghost)
    double precision, intent(out), dimension(num_eqn, 1-num_ghost:maxm+num_ghost) :: amdq,apdq
    ! Locals
    double precision :: fim1, fi, sim1, si, f0
    integer :: i

    do i = 2-num_ghost, num_cells+num_ghost
        ! Compute the wave, speeds, and flux difference

        ! compute characteristic speed in each cell:
        sim1 = auxr(1,i-1)*(1.d0 - 2.d0*qr(1,i-1))
        si   = auxl(1,i  )*(1.d0 - 2.d0*ql(1,i  ))

        ! compute flux in each cell and flux difference:
        fim1 = auxr(1,i-1)*qr(1,i-1)*(1.d0 - qr(1,i-1))
        fi   = auxl(1,i  )*ql(1,i  )*(1.d0 - ql(1,i  ))

        fwave(1,1,i) = fi - fim1

        if (sim1 .lt. 0.d0 .and. si .le. 0.d0) then
            ! left-going
            s(1,i) = sim1
            amdq(1,i) = fwave(1,1,i)
            apdq(1,i) = 0.d0
        else if (sim1 .ge. 0.d0 .and. si .gt. 0.d0) then
            ! right-going
            s(1,i) = si
            amdq(1,i) = 0.d0
            apdq(1,i) = fwave(1,1,i)
        else if (sim1 .lt. 0.d0 .and. si .gt. 0.d0) then
            ! transonic rarefaction
            s(1,i) = 0.5d0*(sim1 + si)

            ! entropy fix:  (perhaps doesn't work for all cases!!!)
            ! This assumes the flux in the transonic case should
            ! correspond to q=0.5 on the side with the smaller umax value.
            f0 = dmin1(auxr(1,i-1),auxl(1,i))*0.25d0
            ! split fwave between amdq and apdq:
            amdq(1,i) = f0 - fim1
            apdq(1,i) = fi - f0

        else
            ! transonic shock
            s(1,i) = 0.5d0*(sim1 + si)
            if (fi-fim1 .lt. 0.d0) then
                amdq(1,i) = fwave(1,1,i)
                apdq(1,i) = 0.d0
            else if (fi-fim1 .gt. 0.d0) then
                amdq(1,i) = 0.d0
                apdq(1,i) = fwave(1,1,i)
            else
                amdq(1,i) = 0.5d0 * fwave(1,1,i)
                apdq(1,i) = 0.5d0 * fwave(1,1,i)
            endif
        endif

    enddo
    return
end subroutine rp1


module sw_flux

        implicit none

	contains

	! Funktion F aus der Shallow Water PDE
	subroutine swF(F,q1,q2)

	double precision, intent(in)					:: q1, q2
	double precision, dimension(2), intent(out)		:: F
	double precision, parameter						:: g = 1d0

	F(1) = q2
	F(2) = q2*q2/q1+g*q1*q1/2.0d0

	end subroutine swF

	! diagonalisierte Jacobi Matrix der Funktion F aus der Shallow Water PDE
	subroutine swA(A,q1,q2)

	double precision, intent(in)					:: q1, q2
	double precision, dimension(2,2), intent(out)	:: A
	double precision, parameter						:: g = 1d0
	double precision								:: c

	c = sqrt(g*q1)

	A(1,1) = q2/q1-c
	A(1,2) = 0d0
	A(2,1) = 0d0
	A(2,2) = q2/q1+c

	end subroutine swA

	! Transformationsmatrix R
	subroutine swR(R,q1,q2)

	double precision, intent(in)					:: q1, q2
	double precision, dimension(2,2), intent(out)	:: R
	double precision, parameter						:: g = 1d0
	double precision								:: c

	c = sqrt(g*q1)

	R(1,1) = 1d0
	R(1,2) = 1d0
	R(2,1) = q2/q1-c
	R(2,2) = q2/q1+c

	end subroutine swR

	! Transformationsmatrix R^-1
	subroutine swRi(Ri,q1,q2)

	double precision, intent(in)					:: q1, q2
	double precision, dimension(2,2), intent(out)	:: Ri
	double precision, parameter						:: g = 1d0
	double precision								:: c, twoc

	c = sqrt(g*q1)
	twoc = 2d0*c

	Ri(1,1) = (q2/q1+c)/twoc
	Ri(1,2) = -1d0/twoc
	Ri(2,1) = (c-q2/q1)/twoc
	Ri(2,2) = 1d0/twoc

	end subroutine swRi

end module sw_flux


module mathtools
   use precision, only: WP
   implicit none
   private

   ! Make public what is useful outside
   public :: Pi,twoPi
   public :: fv_itp_build,fd_itp_build
   public :: inverse_matrix
   public :: cross_product
   public :: normalize

   ! Trigonometric parameters
   real(WP), parameter :: Pi   =3.1415926535897932385_WP
   real(WP), parameter :: twoPi=6.2831853071795864770_WP

   ! Bessel first zero
   !real(WP), parameter :: bessj1_zero=3.8317059702075123115_WP

   ! Blasius data points
   !real(WP), dimension(0:9) :: by0=[0.000000000000000_WP,0.165571818583440_WP,0.650024518764203_WP,1.39680822972500_WP,2.30574664618049_WP,3.28327391871370_WP,4.27962110517696_WP,5.27923901129384_WP,6.27921363832835_WP,7.27921257797747_WP]
   !real(WP), dimension(0:9) :: by1=[0.000000000000000_WP,0.329780063306651_WP,0.629765721178679_WP,0.84604458266019_WP,0.95551827831671_WP,0.99154183259084_WP,0.99897290050990_WP,0.9999216098795_WP,0.99999627301467_WP,0.99999989265063_WP]
   !real(WP), dimension(0:9) :: by2=[0.332057384255589_WP,0.323007152241930_WP,0.266751564401387_WP,0.161360240845588_WP,0.06423404047594_WP,0.01590689966410_WP,0.00240199722109_WP,0.00022016340923_WP,0.00001224984692_WP,0.00000041090325_WP]

contains

   !> Returns cross product in 3 dimensions: z=cross(x,y)
   pure function cross_product(x,y) result(z)
      implicit none
      real(WP), dimension(3), intent(in) :: x,y
      real(WP), dimension(3) :: z
      z(1)=x(2)*y(3)-x(3)*y(2)
      z(2)=x(3)*y(1)-x(1)*y(3)
      z(3)=x(1)*y(2)-x(2)*y(1)
   end function cross_product

   !> Finite volume interpolation metric builder
   subroutine fv_itp_build(n,x,xp,coeff)
      implicit none
      integer,  intent(in) :: n                        !< Polynomial order/number of cells
      real(WP), intent(in) :: xp                       !< Point of evaluation
      real(WP), intent(in),  dimension(n+1) :: x       !< Local mesh (of size n+1)
      real(WP), intent(out), dimension(n)   :: coeff   !< Metric coefficients (of size n)
      real(WP), dimension(:,:), allocatable :: A,B
      integer :: i,j
      ! Allocate the work arrays
      allocate(A(n,n),B(n,n))
      ! Form the matrix
      do j=1,n
         do i=1,n
            A(i,j)=(x(i+1)**(n+1-j)- x(i)**(n+1-j))/(real(n+1-j,WP)*(x(i+1)-x(i)))
         end do
      end do
      ! Invert it
      call inverse_matrix(A,B,n)
      ! Compute metrics
      coeff=0.0_WP
      do j=1,n
         do i=1,n
            coeff(i)=coeff(i)+B(j,i)*xp**(n-j)
         end do
      end do
      ! Deallocate the work arrays
      deallocate(A,B)
   end subroutine fv_itp_build

   !> Finite difference interpolation metric builder
   subroutine fd_itp_build(n,x,xp,coeff)
      implicit none
      integer,  intent(in) :: n                        !< Polynomial order/number of grid points
      real(WP), intent(in) :: xp                       !< Point of evaluation
      real(WP), intent(in),  dimension(n) :: x         !< Local mesh (of size n)
      real(WP), intent(out), dimension(n) :: coeff     !< Metric coefficients (of size n)
      real(WP), dimension(:,:), allocatable :: A,B
      integer :: i,j
      ! Allocate the work arrays
      allocate(A(n,n),B(n,n))
      ! Form the matrix
      do j=1,n
         do i=1,n
            A(i,j)=(x(i)-xp)**(j-1)
         end do
      end do
      ! Invert it
      call inverse_matrix(A,B,n)
      ! Compute metrics
      coeff=B(1,:)
      ! Deallocate the work arrays
      deallocate(A,B)
   end subroutine fd_itp_build

   !> Inverse matrix using Gauss elimination
   subroutine inverse_matrix(A,B,n)
      implicit none
      integer,  intent(in) :: n                    !< Matrix size
      real(WP), intent(inout), dimension(n,n) :: A   !< Matrix to inverse - it is destroyed
      real(WP), intent(out),   dimension(n,n) :: B   !< Matrix inverse
      integer :: i,l
      ! Zero out inverse
      B=0.0_WP
      ! Forward elimination
      do i=1,n
         B(i,i)=1.0_WP
         B(i,:)=B(i,:)/A(i,i)
         A(i,:)=A(i,:)/A(i,i)
         do l=i+1,n
            B(l,:)=B(l,:)-A(l,i)*B(i,:)
            A(l,:)=A(l,:)-A(l,i)*A(i,:)
         end do
      end do
      ! Backward substitution
      do i=n,1,-1
         do l=i+1,n
            B(i,:)=B(i,:)-A(i,l)*B(l,:)
         end do
      end do
   end subroutine inverse_matrix

   ! Returns normalized vector: w=v/|v|
   pure function normalize(v) result(w)
      implicit none
      real(WP), dimension(3), intent(in) :: v
      real(WP), dimension(3)             :: w
      w=v/(norm2(v)+tiny(1.0_WP))
   end function normalize

end module mathtools


program main

implicit none

        integer, parameter :: MAXIMUM = 10000
        integer :: sumn, n

        sumn = 0

        do n = 1, MAXIMUM -1, 1
                if(is_amicable(n)) then
                        call inc(sumn, n)
                endif
        end do

        print*, sumn

contains

        ! This is here because I really miss the '+=' operator from C

        pure subroutine inc(base, offset)

                integer, intent(out) :: base
                integer, intent(in) :: offset

                base = base + offset

                return

        end subroutine inc

        ! This is here because I really miss the '-=' operator from C

        pure subroutine dec(base, offset)

                integer, intent(out) :: base
                integer, intent(in) :: offset

                base = base - offset

                return

        end subroutine dec

        pure function is_amicable(n)

                integer, intent(in) :: n
                logical :: is_amicable

                integer :: i, k, sum_a, sum_b
                sum_a = 0
                sum_b = 0

                k = (n / 2) + 1

                do i = 1, k - 1, 1
                        if(mod(n, i) == 0) then
                                call inc(sum_a, i)
                        endif
                end do

                do i = 1, sum_a - 1, 1

                        if(mod(sum_a, i) == 0) then
                                call inc(sum_b, i)
                        endif

                end do

                is_amicable = ((sum_b == n) .AND. (n /= i))

                return

        end function is_amicable

end program main


program eigen

  !
  !  Demonstrate how to call an external library
  !

  implicit none

  interface

     subroutine zgeev(JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, &
          & LWORK, RWORK, INFO)
       character :: JOBVL, JOBVR
       integer :: INFO, LDA, LDVL, LDVR, LWORK, N
       real(8) :: RWORK(*)
       complex(8) :: A(*), VL(*), VR(*), W(*), WORK(*)
     end subroutine zgeev

  end interface

  complex(8), dimension(:, :), allocatable :: array, leftvectors, rightvectors
  complex(8), dimension(:), allocatable :: eigenvalues, work1
  real(8), dimension(:), allocatable :: work2
  real(8), dimension(2) :: rand
  integer :: n, i, j, info

  read(*, *) n

  allocate(array(n, n), eigenvalues(n), work1(2*n), work2(2*n), &
       & leftvectors(n, n), rightvectors(n, n))

  do j = 1, n

     do i = 1, n

        call random_number(rand)

        array(i, j) = cmplx(rand(1), rand(2))

     end do

  end do

  call zgeev('V', 'V', n, array, n, eigenvalues, leftvectors, n, rightvectors, &
       & n, work1, 2*n, work2, info)

  write(*,*) 'Return status: ', info
  write(*,*) eigenvalues

  open(unit=1, form='unformatted', file='leftvectors', action='write')
  open(unit=2, form='unformatted', file='rightvectors', action='write')

  write(1) leftvectors
  write(2) rightvectors

  close(1)
  close(2)

end program eigen


program array_op_5
implicit none

integer :: a(2, 2, 1), b(2, 2, 1)
complex :: c(2, 2, 1)
integer :: i, j, k

do i = 1, 2
    do j = 1, 2
        do k = 1, 1
            a(i, j, k) = i + j + k
            b(i, j, k) = i*j*k
        end do
    end do
end do

c = a + (0.0, 1.0)*b
call check(c, 0)

c = -a + (0.0, 1.0)*(-b)
call check(c, 1)

contains

    subroutine check(c, op_code)
    implicit none

    complex, intent(in) :: c(:, :, :)
    integer, intent(in) :: op_code

    integer :: i, j, k
    real :: left, right

    do i = lbound(c, 1), ubound(c, 1)
        do j = lbound(c, 2), ubound(c, 2)
            do k = lbound(c, 3), ubound(c, 3)
                select case(op_code)
                    case (0)
                        left = i + j + k
                        right = i*j*k
                        if(c(i, j, k) /= left + right*(0.0, 1.0)) error stop
                    case (1)
                        left = i + j + k
                        right = i*j*k
                        if(c(i, j, k) /= -left  - right*(0.0, 1.0)) error stop
                end select
            end do
        end do
    end do

    end subroutine check

end program


program main
   real, allocatable, dimension(:, :, :, :) :: arr, arr_copy
   integer :: i, me, nimg
   real :: redc, sumc, sumnc, rednc
   real :: eps = epsilon(0.)
   logical :: failc, failnc

   allocate(arr(9, 20, 3, 18))

   me = this_image()
   nimg = num_images()

   if (me == 1) then
      arr = reshape([(i, i=1, size(arr))], shape(arr))
   end if

   call co_broadcast(arr, source_image=1)
   arr_copy = arr

   print *, '==> CONTIGUOUS <=='
   sumc = sum(arr)
   redc = sumc
   call co_sum(redc)
   print *, 'sumc=', sumc
   print *, 'excpected: nimg * sumc=', nimg * sumc
   print *, 'got: redc=', redc

   failc = abs(redc - nimg * sumc) > eps

   print *, '==> NON CONTIGUOUS <=='
   sumnc = sum(arr(::3, ::2, :, ::5))

   call co_sum(arr_copy)
   call co_sum(arr(::3, ::2, :, ::5))

   rednc = sum(arr(::3, ::2, :, ::5))
   print *, 'sumnc=', sumnc
   print *, 'expected (nimg * sumnc)=', nimg * sumnc
   print *, 'expected=', sum(arr_copy(::3, ::2, :, ::5))
   print *, 'got: rednc=', rednc

   failnc = abs(rednc - nimg * sumnc) > eps

   sync all

   if (failc .or. failnc) then
      write(*, *) 'Test failed!'
      error stop 5
   else
      write(*, *) 'Test passed.'
   end if
   deallocate(arr)
end program


      PROGRAM LA_SPTSV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_PTSV
!  .. "IMPLICIT STATEMENT" ..
      IMPLICIT NONE
!  .. "Parameters" ..
      REAL(WP), PARAMETER :: ONE = 1.0_WP, THREE = 3.0_WP
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N, NRHS
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:), D(:), E(:), B(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SPTSV Example Program Results.'
      N = 5; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      ALLOCATE (A(N), D(N), E(N-1), B(N,NRHS) )

      OPEN(UNIT=21,FILE='ptsv.ma',STATUS='UNKNOWN')
      DO I=1,N
         READ(21,'(F3.0)') A(I);
      ENDDO;
      CLOSE(21)

      E = THREE; D(1) = 2*E(1)+ONE; D(2:N) = 2*E+ONE
      B(1,1) = D(1)+E(1); B(N,1) = E(N-1)+D(N)
      B(2:N-1,1) = 2*E + D(2:N-1)
      DO I = 2, NRHS; B(:,I) = B(:,1)*I;
      ENDDO
      WRITE(*,*) '  on entry:'
      WRITE (*,'(2HD:,8(1X,F9.2))') D
      WRITE (*,'(2HE:,8(1X,F9.2))') E
      WRITE(*,*) 'The RHS matrix B:'
      DO J = 1, N; WRITE (*,*) B(J,:);
      ENDDO

      WRITE(*,*)' CALL LA_PTSV( D, E, B, INFO )'
      CALL LA_PTSV( D, E, B, INFO )

      WRITE(*,*) 'Vector D on exit:'
      DO I = 1, N; WRITE (*,'(F8.5)') D(I);
      ENDDO

      WRITE(*,*) 'Vector E on exit:'
      DO I = 1, N-1; WRITE (*,'(E15.5)') E(I);
      ENDDO

      WRITE(*,*) 'The matrix B on exit:'
      DO J = 1, N; WRITE (*,*) B(J,:);
      ENDDO

      WRITE(*,*)'INFO = ',INFO

      END PROGRAM LA_SPTSV_EXAMPLE


	FUNCTION PS_TOTL  ( t850, td850, t500 )
C************************************************************************
C* PS_TOTL								*
C*									*
C* This function computes the total totals index:			*
C*									*
C*      TOTL = ( T850 - T500 ) + ( TD850 - T500 )			*
C*									*
C* REAL PS_TOTL  ( T850, TD850, T500 )                                	*
C*									*
C* Input parameters:							*
C*	T850		REAL		850 mb temperature in Celsius	*
C*	TD850		REAL		850 mb dewpoint in Celsius	*
C*	T500		REAL		500 mb temperature in Celsius	*
C*									*
C* Output parameters:							*
C*	PS_TOTL		REAL		Total totals index		*
C**									*
C* Log:									*
C* P. Kocin/GSFC	1980						*
C* M. Goodman/RDS	11/84	Cleaned code				*
C* M. desJardins/GSFC	 3/88	Cleaned code				*
C************************************************************************
        INCLUDE      'GEMPRM.PRM'
        INCLUDE      'ERMISS.FNC'
C------------------------------------------------------------------------------
	IF ( ERMISS (t850) .or. ERMISS (td850) .or. ERMISS (t500) ) THEN
	    PS_TOTL = RMISSD
	  ELSE
C
C*	    Compute vertical totals.
C
	    vtot = PS_VTOT ( t850,  t500 )
C
C*	    Compute cross totals.
C
	    ctot = PS_CTOT ( td850, t500 )
C
C*	    The sum is the total totals.
C
	    PS_TOTL = ctot + vtot
	END IF
C*
	RETURN
	END


program fizzbuzz_if
   integer :: i

   do i = 1, 100
      if     (mod(i,15) == 0) then; print *, 'FizzBuzz'
      else if (mod(i,3) == 0) then; print *, 'Fizz'
      else if (mod(i,5) == 0) then; print *, 'Buzz'
      else;                         print *, i
      end if
   end do
end program fizzbuzz_if


      SUBROUTINE MATMUL (M,N,P, A,B, C)

C general purpose matrix multiply - multiplies an MxN array (A)
C by a NxP array (B) to yield an MxP array (C).

      INTEGER   I,J,K, M,N,P
      REAL      A(M,N), B(N,P), C(M,P), TOT

      DO 100 I = 1,M
      DO 200 J = 1,P
         TOT = 0.0
         DO 300 K = 1,N
            TOT = TOT + A(I,K) * B(K,J)
300      CONTINUE
         C(I,J) = TOT
200   CONTINUE
100   CONTINUE

      END


!==============================================================================!
  real function Math_Mod_Tri_Area_Z(xa, ya,   &
                                    xb, yb,   &
                                    xc, yc)
!------------------------------------------------------------------------------!
!   Area of a tringle in xy plane defined with nodes "a", "b", "c"
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real, intent(in) :: xa, ya, xb, yb, xc, yc
!==============================================================================!
!                                                                              !
!                c                                                             !
!               / \                                                            !
!              /   \                                                           !
!             /     \                                                          !
!            /       \                                                         !
!           /         \                                                        !
!          a-----------b                                                       !
!                                                                              !
!------------------------------------------------------------------------------!

  Math_Mod_Tri_Area_Z = abs(xa * (yb-yc) + xb * (yc-ya) + xc * (ya-yb)) * 0.5

  end function


!
! The Great Computer Language Shootout
! http://shootout.alioth.debian.org/
!
! Contributed by Sebastien Loisel
!
! Fortran version by Simon Geard and Arjen Markus
!
! OVERVIEW: In this test, we solve an ordinary differential equation
!    u'=f(t,u)
! using the Trapezoid numerical method, which can be written as
!    (u[k+1]-u[k])=(f(t[k],u[k])+f(t[k]+dt,u[k+1]))*dt/2,
! where t[k], u[k], dt and the function f are known and u[k+1] is the
! unknown.
!
! Since u[k+1] appears on both sides of the equation, we use an iterative
! solver called the newton iteration to compute u[k+1]. The newton iteration
! computes the solution to
!    h(x)=0
! where h is a known function and x is the unknown 0 of h, using the method
!    x[k+1]=x[k]-f(x[k])/f'(x[k]).
! Here, f' denotes the derivative of f.
!
! To compute f' from the definition of f alone, we use a technique called
! automatic differentiation. This works by replacing all floating point
! variables by a special type we call ad (for automatic differentiation.)
! If the python program for f is called with parameter x of type ad,
! it will do the same work as if it were called with the equivalent parameter
! of type floating point, but will also return f'. That's why it's called
! "automatic."
!
! To shake things up, we also have another type, fl (for "float") which
! works exactly like a double precision floating point, but with much
! less precision.
!
! Summary of classes:
!
! ad -- automatic differentiation type
! fl -- low precision floating point type
! mycomplex -- complex numbers whose real and imaginary parts can be fl
! trapezoid_method_rooter -- implements the function that the trapezoid method
!                            must solve

program implicitode
  use function_params
  use autoDiff
  implicit none

  type(ad), external :: mysqrt, rat, simple
  type(ad)    :: res
  type(fdata) :: gparams
  type(fdata) :: tparams
  character(len=33) :: str
  real*8  :: x, dt, y0, r, u_t0, t1, t0
  complex*8 :: xc
  integer :: i,n,ns
  character(len=8) argv

  call getarg(1,argv)
  if (len(trim(argv)) == 0) then
     n = 50
  else
     read(argv,*) n
  end if

  res = rat(ad(0.25d0,1))
  write(*,'(2(a,es20.14e2))') 'rational_taylor_series: ',res%x,' ',res%dx

  gparams%a = 2.0d0
  x = newton(mysqrt,gparams,ad(1.0d0,0.0d0),10)
  write(*,'(2(a,es21.14e2))') 'newton-sqrt_2:',x
  x = newton(rat,gparams,ad(-1.0d0,0.0d0),6)
  res = rat(ad(x,0))
  write(*,'(a,es21.14e2)') 'newton-rat: ',x

  !
  ! Simple case that is easy to check:
  !
  !              u' = 1/(2u) with u(1) = 2
  !
  !           => u = sqrt(t+3)
  !
  ! so the test is to ensure u(6) = 3
  !
  t0 = 1.0d0            ! Initial value of the parameter
  u_t0 = 2.0d0          ! Value of u at t0: u(1) = 2
  t1 = 6.0d0            ! Final (target) value of parameter t
  dt = (t1 - t0)/n      ! Parameter step size
  call trapezoidal(simple,gparams,t0,dt,u_t0,n,r)
  write(*,'(a,es17.10e2)') 'u(6) = ',r

  x = 1.0d0
  dt = 0.02d0
  y0 = 1.0d0/(4*n)
  call integrate_functions(x,dt,y0,4*n)

contains

  subroutine integrate_functions(t0,dt,y0,n)
    real*8, intent(in)  :: t0
    real*8, intent(in)  :: dt
    real*8, intent(in)  :: y0
    integer, intent(in) :: n
    call trapezoidal(mysqrt,gparams,x,dt,y0,n,r)
    print *, 'i1: ',r
    call trapezoidal(rat,gparams,x,dt,y0,n,r)
    print *, 'i2: ',r
  end subroutine integrate_functions

  subroutine trapezoidal(g,gparams,t0,dt,y0,numsteps,r)
    type(ad), external        :: g
    type(fdata), intent(in) :: gparams
    real*8, intent(in)      :: t0
    real*8, intent(in)      :: dt
    real*8, intent(in)      :: y0
    integer, intent(in)     :: numsteps
    real*8, intent(inout)   :: r

    real*8                  :: t, y
    real*8, external        :: trapezoid_method
    type(fdata)             :: params
    type(ad)                :: val, y1
    integer                 :: i, j
    real*8                  :: t1
    !    (u[k+1]-u[k])=(f(t[k],u[k])+f(t[k]+dt,u[k+1]))*dt/2,
    y = y0
    do i=1,numsteps
       t1 = t0 + i*dt
       y1 = ad(y,1)
       do j=1,10
          val = (g(y,gparams) + g(y1,gparams))*(dt/2.0d0) + y - y1
          y1 = y1 - val%x/val%dx
       end do
       y = y1%x
    end do
    r = y
  end subroutine trapezoidal

  real*8 function newton(g,params,x,n)
    type(ad), external                :: g
    type(ad), intent(in)              :: x
    type(fdata), optional, intent(in) :: params
    integer, optional, intent(in)     :: n
    integer :: i
    type(ad) :: val
    if (present(n)) then
       ns = n
    else
       ns = 10
    end if
    newton = x%x
    do i=1,ns
       val = g(newton,params)
       newton = newton - val%x/val%dx
    end do
  end function newton

  real*8 function newton_trapez(func, params, y0)

    f0 = func(y0,params)
    do i = 1,nsteps
       val = trap_impl(func,params,y1,y0,f0)
       y1 = y1 - val%x/val%dx
    enddo

    newton = y1

  end function newton_trapez

  type(ad) function trap_impl(func, params, y1, y0, f0)
    trap_impl = y1 - (func(y1,params)+f0)*hdelta - y0
  end function trap_impl

end program implicitode

type(ad) function rat(x, params)
  use function_params
  use autoDiff

  type(ad), intent(in) :: x
  type(fdata), intent(in), optional :: params

  rat = (1 + 2*x + 3*x**2 + 7*x**6 + 5*x**11) / (2 + 5*x - 6*x**3 - 3*x**7)
end function rat

type(ad) function mysqrt(x, params)
  use function_params
  use autoDiff

  type(ad), intent(in)    :: x
  type(fdata), intent(in), optional :: params
  mysqrt = x*x - params%a
end function mysqrt

type(ad) function simple(x, params)
  use function_params
  use autoDiff

  type(ad), intent(in)    :: x
  type(fdata), intent(in), optional :: params

  simple = 0.5d0/x
end function simple


module korc_coords
  !! @note Module containing subroutines to calculate the position of
  !! the simulated particles in toroidal and cylindrical coordinates. @endnote
  use korc_types
  use korc_constants

  IMPLICIT NONE

  PUBLIC :: cart_to_cyl,&
       cart_to_cyl_p,&
       cart_to_tor_check_if_confined,&
       cart_to_tor_p,&
       cyl_to_cart,&
       cyl_check_if_confined,&
       cyl_check_if_confined_p

CONTAINS

  subroutine cart_to_cyl(X,Xcyl)
    !! @note  Subroutine that converts the position of simulated particles
    !! from Cartesian \((x,y,z)\) to cylindrical \((R,\phi,Z)\) coordinates.
    !! @endnote
    !! Here, the coordinate transformation is:
    !!
    !! $$R = \sqrt{x^2 + y^2},$$
    !! $$\phi = \arctan{\left( \frac{y}{x} \right)},$$
    !! $$Z = z.$$
    implicit none
    REAL(rp), DIMENSION(:,:), ALLOCATABLE, INTENT(IN)      :: X
    !! Particles' position in Cartesian coordinates. X(1,:) = \(x\), X(2,:)
    !! = \(y\), X(3,:) = \(z\)
    REAL(rp), DIMENSION(:,:), ALLOCATABLE, INTENT(INOUT)   :: Xcyl
    !! Particles' position in cylindrical coordinates. Xcyl(1,:) = \(R\),
    !! Xcyl(2,:) = \(\phi\), Xcyl(3,:) = \(Z\)
    INTEGER                                                :: pp
    !! Iterator.
    INTEGER                                                :: ss
    !! Iterator.

!    write(output_unit_write,'("X_X: ",E17.10)') X(1:10,1)
!    write(output_unit_write,'("X_Y: ",E17.10)') X(1:10,2)
!    write(output_unit_write,'("X_Z: ",E17.10)') X(1:10,3)

    if (X(2,1).eq.0) then
       ss=1_idef
    else
       ss = size(X,1)
    end if

!    write(output_unit_write,*) 'varX',X(:,1)
!    write(output_unit_write,*) 'varY',X(:,2)
!    write(output_unit_write,*) 'varR',Xcyl(:,1)
!    write(output_unit_write,*) 'varPHI',Xcyl(:,2)

!    !$OMP PARALLEL DO FIRSTPRIVATE(ss) PRIVATE(pp) SHARED(X,Xcyl)
    do pp=1_idef,ss
!       write(output_unit_write,*) 'pp',pp
       Xcyl(pp,1) = SQRT(X(pp,1)**2 + X(pp,2)**2)
       Xcyl(pp,2) = ATAN2(X(pp,2), X(pp,1))
       Xcyl(pp,2) = MODULO(Xcyl(pp,2), 2.0_rp*C_PI)
       Xcyl(pp,3) = X(pp,3)
    end do
!    !$OMP END PARALLEL DO

!    write(output_unit_write,*) 'varX',X(:,1)
!    write(output_unit_write,*) 'varY',X(:,2)
!    write(output_unit_write,*) 'varR',Xcyl(:,1)
!    write(output_unit_write,*) 'varPHI',Xcyl(:,2)

  end subroutine cart_to_cyl

  subroutine cart_to_cyl_p(pchunk,X_X,X_Y,X_Z,Y_R,Y_PHI,Y_Z)
    implicit none
    INTEGER, INTENT(IN)  :: pchunk
    REAL(rp), DIMENSION(pchunk), INTENT(IN)      :: X_X
    REAL(rp), DIMENSION(pchunk), INTENT(IN)      :: X_Y
    REAL(rp), DIMENSION(pchunk), INTENT(IN)      :: X_Z

    REAL(rp), DIMENSION(pchunk), INTENT(OUT)   :: Y_R
    REAL(rp), DIMENSION(pchunk), INTENT(OUT)   :: Y_PHI
    REAL(rp), DIMENSION(pchunk), INTENT(OUT)   :: Y_Z

    INTEGER                                                :: pp
    !! Iterator.

    !$OMP SIMD
!    !$OMP& aligned(Y_R,Y_PHI,Y_Z,X_X,X_Y,X_Z)
    do pp=1_idef,pchunk
       Y_R(pp) = SQRT(X_X(pp)*X_X(pp) + X_Y(pp)*X_Y(pp))
       Y_PHI(pp) = ATAN2(X_Y(pp), X_X(pp))
       Y_PHI(pp) = MODULO(Y_PHI(pp), 2.0_rp*C_PI)
       Y_Z(pp) = X_Z(pp)
    end do
    !$OMP END SIMD

  end subroutine cart_to_cyl_p

  subroutine cyl_to_cart(Xcyl,X)
    !! @note  Subroutine that converts the position of simulated particles
    !! from cylindrical \((R,\phi,Z)\) to Cartesian \((x,y,z)\ coordinates.
    !! @endnote
    !! Here, the coordinate transformation is:
    !!
    !! $$x=R\cos(\phi),$$
    !! $$y=R\sin(\phi),,$$
    !! $$Z = z.$$
    implicit none
    REAL(rp), DIMENSION(:,:), ALLOCATABLE, INTENT(INOUT):: X
    !! Particles' position in Cartesian coordinates. X(1,:) = \(x\), X(2,:)
    !! = \(y\), X(3,:) = \(z\)
    REAL(rp), DIMENSION(:,:), ALLOCATABLE, INTENT(IN)   :: Xcyl
    !! Particles' position in cylindrical coordinates. Xcyl(1,:) = \(R\),
    !! Xcyl(2,:) = \(\phi\), Xcyl(3,:) = \(Z\)
    INTEGER                                                :: pp
    !! Iterator.
    INTEGER                                                :: ss
    !! Iterator.

    if (Xcyl(2,1).eq.0) then
       ss=1_idef
    else
       ss = size(Xcyl,1)
    end if

    !$OMP PARALLEL DO FIRSTPRIVATE(ss) PRIVATE(pp) SHARED(X,Xcyl)
    do pp=1_idef,ss
       X(pp,1) = Xcyl(pp,1)*cos(Xcyl(pp,2))
       X(pp,2) = Xcyl(pp,1)*sin(Xcyl(pp,2))
       X(pp,3) = Xcyl(pp,3)
    end do
    !$OMP END PARALLEL DO
  end subroutine cyl_to_cart

  subroutine cyl_check_if_confined(F,Xcyl,flag)
    implicit none
    TYPE(FIELDS), INTENT(IN)                               :: F
    !! An instance of the KORC derived type FIELDS.
    REAL(rp), DIMENSION(:,:), ALLOCATABLE, INTENT(IN)      :: Xcyl
    !! Particles' position in cylindrical coordinates. Xcyl(1,:) = \(R\),
    !! Xcyl(2,:) = \(\phi\), Xcyl(3,:) = \(Z\)
    INTEGER(is), DIMENSION(:), ALLOCATABLE, INTENT(INOUT)   :: flag
    REAL(rp)                                               :: a
    !! Distance to plasma edge as measured from the magnetic axis.
    REAL(rp)                                               :: Ro
    !! Radial position of the magnetic axis.
    INTEGER                                                :: pp
    !! Iterator.
    INTEGER                                                :: ss
    !! Iterator.

    if (Xcyl(2,1).eq.0) then
       ss=1_idef
    else
       ss = size(Xcyl,1)
    end if

    a = F%AB%a
    Ro = F%AB%Ro

    !$OMP PARALLEL DO FIRSTPRIVATE(ss,a,Ro) PRIVATE(pp) SHARED(Xcyl,flag)
    do pp=1_idef,ss
       if (sqrt((Xcyl(pp,1)-Ro)**2+Xcyl(pp,3)**2) .gt. a) then
          flag(pp)=0_is
       endif
    end do
    !$OMP END PARALLEL DO
  end subroutine cyl_check_if_confined

  subroutine cyl_check_if_confined_p(pchunk,a,R0,Xcyl_R,Xcyl_Z,flag)
    implicit none
    INTEGER, INTENT(IN)  :: pchunk
    REAL(rp),DIMENSION(pchunk),  INTENT(IN)      :: Xcyl_R
    REAL(rp),DIMENSION(pchunk),  INTENT(IN)      :: Xcyl_Z
    INTEGER(is),DIMENSION(pchunk),INTENT(INOUT)   :: flag
    REAL(rp),  INTENT(IN)                            :: a,R0
    !! Distance to plasma edge as measured from the magnetic axis.
    INTEGER                                  :: cc

    !$OMP SIMD
!    !$OMP& aligned(Xcyl_R,Xcyl_Z,flag)
    do cc=1_idef,pchunk
       if (sqrt((Xcyl_R(cc)-R0)**2+Xcyl_Z(cc)**2) .gt. a) flag(cc)=0_is
    end do
    !$OMP END SIMD

  end subroutine cyl_check_if_confined_p

  subroutine cart_to_tor_check_if_confined(X,F,Xtor,flag)
    !! @note Subroutine that converts the position of simulated particles
    !! from Cartesian \((x,y,z)\) to toroidal \((r,\theta, \zeta)\) coordinates.
    !! In addition to performing the coordinate transformation, this
    !! subroutine checks whether a given particle is within the plasma or not.
    !! A particle is not longer considered to be within the plasma if its
    !! minor radius \(r > r_{edge}\), where \(r_{edge}\) is the radial
    !! distance to the plasma edge as measured from the magnetic axis. For
    !! more details see the analytical model of the magnetic field in
    !! [[korc_types]] and [[korc_fields]].
    !!
    !! The coordinate transformation is given by:
    !!
    !! $$r = \sqrt{ \left[\sqrt{x^2 + y^2}-R_0\right]^2 + z^2 },$$
    !! $$\theta = \arctan{\left( \frac{z}{\sqrt{x^2 + y^2}-Ro} \right)}.$$
    !! $$\zeta = \arctan{\left( \frac{x}{y} \right)},$$
    !!
    !! where \(R_0\) is the radial position of the magnetic axis.
    REAL(rp), DIMENSION(:,:), ALLOCATABLE, INTENT(IN)      :: X
    !! Particles' position in Cartesian coordinates. X(1,:) = \(x\), X(2,:)
    !! = \(y\), X(3,:) = \(z\)
    TYPE(FIELDS), INTENT(IN)                               :: F
    !! An instance of the KORC derived type FIELDS.
    REAL(rp), DIMENSION(:,:), ALLOCATABLE, INTENT(INOUT)   :: Xtor
    !! Particles' position in cylindrical coordinates. Xtor(1,:) =
    !! \(r\), Xtor(2,:) = \(\theta\), Xtor(3,:) = \(\zeta\)
    INTEGER(is), DIMENSION(:), ALLOCATABLE, INTENT(INOUT)  :: flag
    REAL(rp)                                               :: a
    !! Distance to plasma edge as measured from the magnetic axis.
    REAL(rp)                                               :: Ro
    !! Radial position of the magnetic axis.
    INTEGER                                                :: pp
    !! Iterator.
    INTEGER                                                :: ss
    !! Iterator.

    if (X(2,1).eq.0) then
       ss=1_idef
    else
       ss = size(X,1)
    end if

    a = F%AB%a
    Ro = F%AB%Ro

!    write(output_unit_write,'("X c2tor: ",E17.10)') X(1,:)

    !$OMP PARALLEL DO FIRSTPRIVATE(ss,a,Ro) PRIVATE(pp) SHARED(X,Xtor,flag)
    do pp=1_idef,ss
       if ( flag(pp) .EQ. 1_is ) then
          Xtor(pp,1) = SQRT( (SQRT(X(pp,1)**2 + X(pp,2)**2) - Ro)**2 + &
               X(pp,3)**2 )
          Xtor(pp,2) = ATAN2(X(pp,3), SQRT(X(pp,1)**2 + X(pp,2)**2) - Ro)
          Xtor(pp,2) = MODULO(Xtor(pp,2),2.0_rp*C_PI)
          Xtor(pp,3) = ATAN2(X(pp,1),X(pp,2))
          Xtor(pp,3) = MODULO(Xtor(pp,3),2.0_rp*C_PI)

!          write(output_unit_write,'("r: ",E17.10)') Xtor(1,1)
!          write(output_unit_write,'("a: ",E17.10)') a
!          write(output_unit_write,'("Ro: ",E17.10)') Ro

          if (Xtor(pp,1) .GT. F%AB%a) then
             flag(pp) = 0_is

!             stop 'error in dist init'
          end if
       end if
    end do
    !$OMP END PARALLEL DO
  end subroutine cart_to_tor_check_if_confined

  subroutine cart_to_tor_p(pchunk,R0,X_X,X_Y,X_Z,T_R,T_T,T_Z)
    INTEGER, INTENT(IN)  :: pchunk
    REAL(rp),  INTENT(IN)      :: R0
    REAL(rp),  INTENT(IN),DIMENSION(pchunk)      :: X_X,X_Y,X_Z
    REAL(rp),  INTENT(OUT),DIMENSION(pchunk)      :: T_R,T_T,T_Z
    REAL(rp),DIMENSION(pchunk)   :: RR
    INTEGER                                      :: cc
    !! Particle chunk iterator.

    !$OMP SIMD
!    !$OMP& aligned(RR,X_X,X_Y,T_R,T_T,T_Z,X_Z)
    do cc=1_idef,pchunk
       RR(cc)=SQRT(X_X(cc)*X_X(cc) + X_Y(cc)*X_Y(cc)) - R0

       T_R(cc) = SQRT( RR(cc)*RR(cc) + X_Z(cc)*X_Z(cc) )
       T_T(cc) = ATAN2(X_Z(cc), RR(cc))
       T_T(cc) = MODULO(T_T(cc),2.0_rp*C_PI)
       T_Z(cc) = ATAN2(X_X(cc),X_Y(cc))
       T_Z(cc) = MODULO(T_Z(cc),2.0_rp*C_PI)
    end do
    !$OMP END SIMD

  end subroutine cart_to_tor_p

  subroutine cart_to_tor_check_if_confined_p(pchunk,ar,R0,X_X,X_Y,X_Z, &
       T_R,T_T,T_Z,flag_cache)
    INTEGER, INTENT(IN)  :: pchunk
    REAL(rp),  INTENT(IN)      :: R0,ar
    REAL(rp),  INTENT(IN),DIMENSION(pchunk)      :: X_X,X_Y,X_Z
    REAL(rp),  INTENT(OUT),DIMENSION(pchunk)      :: T_R,T_T,T_Z
    INTEGER(is),  INTENT(INOUT),DIMENSION(pchunk)      :: flag_cache
    REAL(rp),DIMENSION(pchunk)   :: RR
    INTEGER                                      :: cc
    !! Particle chunk iterator.

    !$OMP SIMD
!    !$OMP& aligned(RR,X_X,X_Y,T_R,T_T,T_Z,X_Z)
    do cc=1_idef,pchunk
       RR(cc)=SQRT(X_X(cc)*X_X(cc) + X_Y(cc)*X_Y(cc)) - R0

       T_R(cc) = SQRT( RR(cc)*RR(cc) + X_Z(cc)*X_Z(cc) )
       T_T(cc) = ATAN2(X_Z(cc), RR(cc))
       T_T(cc) = MODULO(T_T(cc),2.0_rp*C_PI)
       T_Z(cc) = ATAN2(X_X(cc),X_Y(cc))
       T_Z(cc) = MODULO(T_Z(cc),2.0_rp*C_PI)
    end do
    !$OMP END SIMD

    !$OMP SIMD
    do cc=1_idef,pchunk
       if (T_R(cc) .GT. ar) then
          flag_cache(cc) = 0_is
       end if
    end do
    !$OMP END SIMD

  end subroutine cart_to_tor_check_if_confined_p

end module korc_coords


	FUNCTION PR_FOSB  ( tmpc, relh, sped )
C************************************************************************
C* PR_RELH								*
C*									*
C* This function computes the Fosberg Index from temperature, relative	*
C* humidity and wind speed at the surface.				*
C*									*
C* REAL PR_FOSB  ( TMPC, RELH, SPED					*
C*									*
C* Input parameters:							*
C*	TMPC		REAL		Temperature in Celsius		*
C*	RELH		REAL    	Relative humidity in percent	*
C*	SPED		REAL		Wind speed in meters/second	*
C*									*
C* Output parameters:							*
C*	PR_FOSB		REAL		Fosberg Index			*
C**									*
C* Log:									*
C* T. Lee/SAIC		 6/03	Created					*
C************************************************************************
        INCLUDE    	'GEMPRM.PRM'
	PARAMETER       ( A = .03229,  B = .281073, C = .000578 )
	PARAMETER       ( D = 2.22749, E = .160107, F = .014784 )
	PARAMETER       ( G = 21.0606, H = .005565, P = .00035  )
	PARAMETER       ( Q = .483199, R = .3002  , T = 9./5.   )
	PARAMETER       ( U = 1.9425,  V = .868976 )
        INCLUDE    	'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS (tmpc) .or. ERMISS (relh) .or. ERMISS (sped) ) THEN
	    PR_FOSB = RMISSD
	  ELSE
C
C*	    Change temperature to degrees Fahrenheit, wind speed
C*	    from meters/second to miles/hr.
C
	    tf   = PR_TMCF ( tmpc )
	    sknt = PR_MSKN ( sped )
	    smph = PR_KNMH ( sknt )
C
	    IF ( relh .le. 10. )  THEN
		fw = A + B * relh - C * relh * tf
	      ELSE IF ( relh .le. 50. )  THEN
		fw = D + E * relh - F * tf
	      ELSE
		fw = G + H * relh ** 2 - P * relh * tf - Q * relh
	    END IF
C
	    sss  = sqrt ( 1. + ( smph * smph ) )
	    fwd  = fw / 30.
	    fwd2 = fwd * fwd
	    fwd3 = fwd2 * fwd
	    fire = 1. - 2. * fwd + 1.5 * fwd2 - .5 * fwd3
C
C*	    Find the Fosberg Index.
C
	    PR_FOSB  = ( fire * sss ) / R

	END IF
C*
	RETURN
	END


subroutine quad_bezier(img, p1, p2, p3, color)
  type(rgbimage), intent(inout) :: img
  type(point), intent(in) :: p1, p2, p3
  type(rgb), intent(in) :: color

  integer :: i, j
  real :: pts(0:N_SEG,0:1), t, a, b, c, x, y

  do i = 0, N_SEG
     t = real(i) / real(N_SEG)
     a = (1.0 - t)**2.0
     b = 2.0 * t * (1.0 - t)
     c = t**2.0
     x = a * p1%x + b * p2%x + c * p3%x
     y = a * p1%y + b * p2%y + c * p3%y
     pts(i,0) = x
     pts(i,1) = y
  end do

  do i = 0, N_SEG-1
     j = i + 1
     call draw_line(img, point(pts(i,0), pts(i,1)), &
                    point(pts(j,0), pts(j,1)), color)
  end do

end subroutine quad_bezier


c-------------------------------
c interpolator for periodic boundry condition
c input:
c    x_c,f_c,n_c
c    (values on corse grid)
c output:
c    f, rc
c    (value of function on finer grid (must be 2x finer)
c    rc is the return code for un/succesfull interpolation
c
c  method:
c     1: linear interpolation
c     2: C^2 smooth spiline interpolation
c---------------------------------------------
        subroutine intplt(x_c,f_c,n_c,x,f,n,method,rc)

        implicit none
        integer method
        integer n_c, n
        real*8 x_c(n_c), f_c(n_c)
        real*8 x(n), f(n)
        real*8 dx
        real*8 xmid
        integer rc
        real*8 fmid
        integer i,k,l,j
        real*8 f_c_dd(n_c)
        if (method .ne. 1 .and. method .ne. 2) then
           write(0,*) 'interpolator: not supported method'
           rc=0
           return
        endif
c-------
c Checking for Compatibilities
c-------
            if ( (n-1)/(n_c-1) .ne. 2) then
                write(0,*) 'interpolater: not compatible grids'
                rc=0
                return
            endif
            if ( x(n) .ne. x_c(n_c) ) then
               write(0,*) 'interpolator: incompatible grid length'
               write(0,*) ' x_max = ',x(n)
               write(0,*) ' xc_max = ', x_c(n_c)
               !rc=0
               !return
            endif
c--------------------------------------
        if ( method .eq. 1 ) then
           do i=2, n_c
               k = 2*i - 1
               l= k - 1
               f(k) = f_c(i)
               f(l) = (f_c(i) + f_c(i-1))/2
            enddo
            f(1) = f_c(1)
            rc=1
            return
        endif

        if ( method .eq. 2 ) then
          dx = ( x_c(n_c)-x_c(1) )/(n_c-1)
          call Divxx(f_c, dx , n_c, f_c_dd)
          do i=3, n_c
             k=2*i-1
             l=k-1
             f(k) = f_c(i)
             xmid = x(l)
             j=i-1
             fmid = f_c_dd(j)*(xmid-x_c(j-1))**3/(6*dx)
     &              + f_c_dd(j-1)*(x_c(j)-xmid)**3/(6*dx)
     &              + (f_c(j)/dx - f_c_dd(j)*dx/6)*(xmid-x_c(j-1))
     &              + (f_c(j-1)/dx - f_c_dd(j-1)*dx/6)*(x_c(j)-xmid)
             f(l) = fmid
          enddo

          i=2
             k=2*i-1
             l=k-1
             f(k) = f_c(i)
             xmid = x(l)
             j=i-1
             fmid = f_c_dd(j)*(xmid-(x_c(j)-dx))**3/(6*dx)
     &              + f_c_dd(n_c-1)*(x_c(j)-xmid)**3/(6*dx)
     &              + (f_c(j)/dx - f_c_dd(j)*dx/6)*(xmid-(x_c(j)-dx))
     &              + (f_c(n_c-1)/dx - f_c_dd(n_c-1)*dx/6)*(x_c(j)-xmid)
             f(2) = fmid

          f(1)=f_c(1)
          f(n)=f_c(n_c)
          rc=1
          return
        endif

        end


program bench
use, intrinsic:: iso_fortran_env, only: int64
use funcs, only: arctan
use funcs58, only: arctanII

implicit none

real :: tintrinsic, told, tnew
real, allocatable ::  ain(:), aout(:)
integer(int64) :: tic, toc, rate
integer :: i, N
character(12) :: argv

N = 100000
call get_command_argument(1,argv,status=i)
if (i==0) read(argv,*) N

allocate(ain(N), aout(N))

!call random_init()  ! Fortran 2018
call random_number(ain)

call system_clock(tic,count_rate=rate)
aout = atan(ain)
call system_clock(toc)
tintrinsic = (toc-tic)/real(rate)

call system_clock(tic,count_rate=rate)
aout = arctan(ain)

call system_clock(toc)
tnew = (toc-tic)/real(rate)

call system_clock(tic,count_rate=rate)
do i = 1,n
  aout(i) = arctanII(ain(i))
enddo
call system_clock(toc)
told = (toc-tic)/real(rate)

print *,'arctan benchmark, ',N,' size array, time in seconds.'
print '(A,ES13.3,A,ES13.3,A,ES13.3)','intrinsic ',tintrinsic,'  modern Fortran ',tnew,'  Fortran II / 77  ',told
end program


*DECK DRD
      DOUBLE PRECISION FUNCTION DRD (X, Y, Z, IER)
C***BEGIN PROLOGUE  DRD
C***PURPOSE  Compute the incomplete or complete elliptic integral of
C            the 2nd kind. For X and Y nonnegative, X+Y and Z positive,
C            DRD(X,Y,Z) = Integral from zero to infinity of
C                                -1/2     -1/2     -3/2
C                      (3/2)(t+X)    (t+Y)    (t+Z)    dt.
C            If X or Y is zero, the integral is complete.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      DOUBLE PRECISION (RD-S, DRD-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     DRD
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the second kind
C          Standard FORTRAN function routine
C          Double precision version
C          The routine calculates an approximation result to
C          DRD(X,Y,Z) = Integral from zero to infinity of
C                              -1/2     -1/2     -3/2
C                    (3/2)(t+X)    (t+Y)    (t+Z)    dt,
C          where X and Y are nonnegative, X + Y is positive, and Z is
C          positive.  If X or Y is zero, the integral is COMPLETE.
C          The duplication theorem is iterated until the variables are
C          nearly equal, and the function is then expanded in Taylor
C          series to fifth order.
C
C   2.     Calling Sequence
C
C          DRD( X, Y, Z, IER )
C
C          Parameters On Entry
C          Values assigned by the calling routine
C
C          X      - Double precision, nonnegative variable
C
C          Y      - Double precision, nonnegative variable
C
C                   X + Y is positive
C
C          Z      - Double precision, positive variable
C
C
C
C          On Return    (values assigned by the DRD routine)
C
C          DRD     - Double precision approximation to the integral
C
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine. It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C
C          X, Y, Z are unaltered.
C
C   3.    Error Messages
C
C         Value of IER assigned by the DRD routine
C
C                  Value assigned         Error message printed
C                  IER = 1                MIN(X,Y) .LT. 0.0D0
C                      = 2                MIN(X + Y, Z ) .LT. LOLIM
C                      = 3                MAX(X,Y,Z) .GT. UPLIM
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X, Y, and Z
C
C          LOLIM  - Lower limit of valid arguments
C
C                    Not less  than 2 / (machine maximum) ** (2/3).
C
C          UPLIM  - Upper limit of valid arguments
C
C                 Not greater than (0.1D0 * ERRTOL / machine
C                 minimum) ** (2/3), where ERRTOL is described below.
C                 In the following table it is assumed that ERRTOL will
C                 never be chosen smaller than 1.0D-5.
C
C
C                    Acceptable values for:   LOLIM      UPLIM
C                    IBM 360/370 SERIES   :   6.0D-51     1.0D+48
C                    CDC 6000/7000 SERIES :   5.0D-215    2.0D+191
C                    UNIVAC 1100 SERIES   :   1.0D-205    2.0D+201
C                    CRAY                 :   3.0D-1644   1.69D+1640
C                    VAX 11 SERIES        :   1.0D-25     4.5D+21
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C          ERRTOL    Relative error due to truncation is less than
C                    3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2.
C
C
C
C        The accuracy of the computed approximation to the integral
C        can be controlled by choosing the value of ERRTOL.
C        Truncation of a Taylor series after terms of fifth order
C        introduces an error less than the amount shown in the
C        second column of the following table for each value of
C        ERRTOL in the first column.  In addition to the truncation
C        error there will be round-off error, but in practice the
C        total error from both sources is usually less than the
C        amount given in the table.
C
C
C
C
C          Sample choices:  ERRTOL   Relative truncation
C                                    error less than
C                           1.0D-3    4.0D-18
C                           3.0D-3    3.0D-15
C                           1.0D-2    4.0D-12
C                           3.0D-2    3.0D-9
C                           1.0D-1    4.0D-6
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   DRD Special Comments
C
C
C
C          Check: DRD(X,Y,Z) + DRD(Y,Z,X) + DRD(Z,X,Y)
C          = 3 / SQRT(X * Y * Z), where X, Y, and Z are positive.
C
C
C          On Input:
C
C          X, Y, and Z are the variables in the integral DRD(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, Z are unaltered.
C
C
C
C          ********************************************************
C
C          WARNING: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C
C    -------------------------------------------------------------------
C
C
C   Special double precision functions via DRD and DRF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 2nd kind
C
C                  -----------------------------------------
C
C
C                                             2         2   2
C                  E(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) -
C
C                     2      3             2         2   2
C                  -(K/3) SIN (PHI) DRD(COS (PHI),1-K SIN (PHI),1)
C
C
C                                  2        2            2
C                  E(K) = DRF(0,1-K ,1) - (K/3) DRD(0,1-K ,1)
C
C                         PI/2     2   2      1/2
C                       = INT  (1-K SIN (PHI) )  D PHI
C                          0
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind
C
C                  -----------------------------------------
C
C                                               2 2    2
C                  EL2(X,KC,A,B) = AX DRF(1,1+KC X ,1+X ) +
C
C                                              3          2 2    2
C                                 +(1/3)(B-A) X DRD(1,1+KC X ,1+X )
C
C
C
C
C                  Legendre form of alternative ELLIPTIC INTEGRAL
C                  of 2nd kind
C
C                  -----------------------------------------
C
C
C
C                            Q     2       2   2  -1/2
C                  D(Q,K) = INT SIN P  (1-K SIN P)     DP
C                            0
C
C
C
C                                     3          2     2   2
C                  D(Q,K) = (1/3) (SIN Q) DRD(COS Q,1-K SIN Q,1)
C
C
C
C
C                  Lemniscate constant  B
C
C                  -----------------------------------------
C
C
C
C
C                       1    2    4 -1/2
C                  B = INT  S (1-S )    DS
C                       0
C
C
C                  B = (1/3) DRD (0,2,1)
C
C
C                  Heuman's LAMBDA function
C
C                  -----------------------------------------
C
C
C
C                  (PI/2) LAMBDA0(A,B) =
C
C                                    2                2
C                 = SIN(B) (DRF(0,COS (A),1)-(1/3) SIN (A) *
C
C                            2               2         2       2
C                  *DRD(0,COS (A),1)) DRF(COS (B),1-COS (A) SIN (B),1)
C
C                            2       3             2
C                  -(1/3) COS (A) SIN (B) DRF(0,COS (A),1) *
C
C                           2         2       2
C                   *DRD(COS (B),1-COS (A) SIN (B),1)
C
C
C
C                  Jacobi ZETA function
C
C                  -----------------------------------------
C
C                             2                 2       2   2
C                  Z(B,K) = (K/3) SIN(B) DRF(COS (B),1-K SIN (B),1)
C
C
C                                       2             2
C                             *DRD(0,1-K ,1)/DRF(0,1-K ,1)
C
C                               2       3           2       2   2
C                            -(K /3) SIN (B) DRD(COS (B),1-K SIN (B),1)
C
C
C ---------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  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   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Modify calls to XERMSG to put in standard form.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DRD
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      DOUBLE PRECISION LOLIM, TUPLIM, UPLIM, EPSLON, ERRTOL, D1MACH
      DOUBLE PRECISION C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA
      DOUBLE PRECISION MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV
      DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DRD
      IF (FIRST) THEN
         ERRTOL = (D1MACH(3)/3.0D0)**(1.0D0/6.0D0)
         LOLIM  = 2.0D0/(D1MACH(2))**(2.0D0/3.0D0)
         TUPLIM = D1MACH(1)**(1.0E0/3.0E0)
         TUPLIM = (0.10D0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM
         UPLIM  = TUPLIM**2.0D0
C
         C1 = 3.0D0/14.0D0
         C2 = 1.0D0/6.0D0
         C3 = 9.0D0/22.0D0
         C4 = 3.0D0/26.0D0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      DRD = 0.0D0
      IF( MIN(X,Y).LT.0.0D0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         CALL XERMSG ('SLATEC', 'DRD',
     *      'MIN(X,Y).LT.0 WHERE X = ' // XERN3 // ' AND Y = ' //
     *      XERN4, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'DRD',
     *      'MAX(X,Y,Z).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6,
     *      3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,Z).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'DRD',
     *      'MIN(X+Y,Z).LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // XERN6,
     *      2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
      SIGMA = 0.0D0
      POWER4 = 1.0D0
C
   30 MU = (XN+YN+3.0D0*ZN)*0.20D0
      XNDEV = (MU-XN)/MU
      YNDEV = (MU-YN)/MU
      ZNDEV = (MU-ZN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA))
      POWER4 = POWER4*0.250D0
      XN = (XN+LAMDA)*0.250D0
      YN = (YN+LAMDA)*0.250D0
      ZN = (ZN+LAMDA)*0.250D0
      GO TO 30
C
   40 EA = XNDEV*YNDEV
      EB = ZNDEV*ZNDEV
      EC = EA - EB
      ED = EA - 6.0D0*EB
      EF = ED + EC + EC
      S1 = ED*(-C1+0.250D0*C3*ED-1.50D0*C4*ZNDEV*EF)
      S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA))
      DRD = 3.0D0*SIGMA + POWER4*(1.0D0+S1+S2)/(MU*SQRT(MU))
C
      RETURN
      END


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of SPACING() and RRSPACING
module m
  logical, parameter :: test_1 = spacing(3.0) == scale(1.0, -22)
  logical, parameter :: test_2 = spacing(-3.0) == scale(1.0, -22)
  logical, parameter :: test_3 = spacing(3.0d0) == scale(1.0, -51)
  logical, parameter :: test_4 = spacing(0.) == tiny(0.)
  logical, parameter :: test_11 = rrspacing(3.0) == scale(0.75, 24)
  logical, parameter :: test_12 = rrspacing(-3.0) == scale(0.75, 24)
  logical, parameter :: test_13 = rrspacing(3.0d0) == scale(0.75, 53)
  logical, parameter :: test_14 = rrspacing(0.) == 0.
end module


C$Procedure  MXMTG  ( Matrix times matrix transpose, general dimension )

      SUBROUTINE MXMTG ( M1, M2, NR1, NC1C2, NR2, MOUT )

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

      INTEGER            NR1
      INTEGER            NC1C2
      INTEGER            NR2
      DOUBLE PRECISION   M1   ( NR1,NC1C2 )
      DOUBLE PRECISION   M2   ( NR2,NC1C2 )
      DOUBLE PRECISION   MOUT ( NR1,NR2   )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       M1        I     Left-hand matrix to be multiplied.
C       M2        I     Right-hand matrix whose transpose is to be
C                       multiplied.
C       NR1       I     Row dimension of M1 and row dimension of MOUT.
C       NC1C2     I     Column dimension of M1 and column dimension of
C                       M2.
C       NR2       I     Row dimension of M2 and column dimension of
C                       MOUT.
C       MOUT      O     Product matrix M1 * M2**T.
C                       MOUT must not overwrite either M1 or M2.
C
C$ Detailed_Input
C
C      M1      M1 may be any double precision matrix of arbitrary size.
C
C      M2      M2 may be any double precision matrix of arbitrary size.
C              The number of columns in M2 must match the number of
C              columns in M1.
C
C      NR1     The number of rows in both M1 and MOUT.
C
C      NC1C2   The number of columns in M1 and (by necessity) the number
C              of columns of M2.
C
C      NR2     The number of rows in both M2 and the number of columns
C              in MOUT.
C
C$ Detailed_Output
C
C      MOUT    This is a double precision matrix of dimension NR1 x NR2.
C                                                                    T
C              MOUT is the product matrix given by MOUT = (M1) x (M2)
C              where the superscript "T" denotes the transpose matrix.
C
C              MOUT must not overwrite M1 or M2.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C      The code reflects precisely the following mathematical expression
C
C      For each value of the subscript I from 1 to NR1, and J from 1
C      to NR2:
C
C      MOUT(I,J) = Summation from K=1 to NC1C2 of  ( M1(I,K) * M2(J,K) )
C
C      Notice that the order of the subscripts of M2 are reversed from
C      what they would be if this routine merely multiplied M1 and M2.
C      It is this transposition of subscripts that makes this routine
C      multiply M1 and the TRANPOSE of M2.
C
C      Since this subroutine operates on matrices of arbitrary size, it
C      is not feasible to buffer intermediate results.  Thus, MOUT
C      should NOT overwrite either M1 or M2.
C
C$ Examples
C
C
C     Let M1 = | 1.0D0  2.0D0  3.0D0 |      NR1   = 2
C              |                     |      NC1C2 = 3
C              | 3.0D0  2.0D0  1.0D0 |      NR2   = 4
C
C
C     Let M2 = | 1.0D0  2.0D0  0.0D0 |
C              |                     |
C              | 2.0D0  1.0D0  2.0D0 |
C              |                     |
C              | 1.0D0  2.0D0  0.0D0 |
C              |                     |
C              | 2.0D0  1.0D0  2.0D0 |
C
C      then the call
C
C      CALL MXMTG ( M1, M2, NR1, NC1C2, NR2, MOUT )
C
C      produces the matrix
C
C
C      MOUT = | 5.0D0  10.0D0  5.0D0  10.0D0 |
C             |                              |
C             | 7.0D0  10.0D0  7.0D0  10.0D0 |
C
C
C$ Restrictions
C
C      No error checking is performed to prevent numeric overflow or
C      underflow.
C
C      No error checking is performed to determine if the input and
C      output matrices have, in fact, been correctly dimensioned.
C
C      The user is responsible for checking the magnitudes of the
C      elements of M1 and M2 so that a floating point overflow does
C      not occur.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     matrix times matrix_transpose n-dimensional_case
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION   SUM
      INTEGER            I
      INTEGER            J
      INTEGER            K

C
C  Perform the matrix multiplication
C
      DO I = 1, NR1

         DO J = 1, NR2
            SUM = 0.D0

            DO K = 1, NC1C2
               SUM = SUM + M1(I,K)*M2(J,K)
            END DO

            MOUT(I,J) = SUM

         END DO

      END DO

      RETURN
      END


module diff
    implicit none

    contains

    subroutine ddx(u,h)
    ! take the forward derivative wrt x

        real, dimension(:,:), intent(inout) :: u
        real, intent(in) :: h

        u = (cshift(u,shift=1,dim=1) - u)/h
    end subroutine

    subroutine ddy(u,h)
    ! take the forward derivative wrt y

        real, dimension(:,:), intent(inout) :: u
        real, intent(in) :: h

        u = (cshift(u,shift=1,dim=2) - u)/h
    end subroutine

    subroutine lap(u,h)
    ! calculate the finite difference approximation to the laplacian

        real, dimension(:,:), intent(inout) :: u
        real, intent(in) :: h

        u = ( cshift(u,shift=+1, dim=2) &
             +cshift(u,shift=-1,dim=2) &
             +cshift(u,shift=+1,dim=1) &
             +cshift(u,shift=-1,dim=1) &
             -4*u) / h**2

    end subroutine

    function myiter(p,h)
    ! calculate the iteration for the Poisson solver. Note that this is exactly
    ! the same as the laplacian, but without the final -4*u term, and
    ! non-periodic boundaries on the left and right (it uses Neumann BCs
    ! instead)

        real, dimension(:,:), intent(in) :: p
        real, intent(in) :: h
        real, dimension(size(p,1),size(p,2)) :: myiter
        integer :: nnx

        nnx = size(p,1)

        myiter = (cshift(p,shift=+1, dim=2) &
             +cshift(p,shift=-1,dim=2) &
             +cshift(p,shift=+1,dim=1) &
             +cshift(p,shift=-1,dim=1))
        myiter(1,:) = myiter(1,:)-p(nnx,:)
        myiter(nnx,:) = myiter(nnx,:)-p(1,:)
    end function

    subroutine xavg(u)
    ! calculate the forward average wrt x

        real, dimension(:,:), intent(inout) :: u
        u = (cshift(u,shift=1,dim=1) + u)/2
    end subroutine

    subroutine yavg(u)
    ! calculate the forward averate wrt y

        real, dimension(:,:), intent(inout) :: u

        u = (cshift(u,shift=1,dim=2) + u)/2
    end subroutine

end


program linear_algebra
  implicit none

  real, dimension(3, 3) :: A
  real, dimension(3) :: x, y

  A(1, :) = (/  0,  2,  1 /)
  A(2, :) = (/  1, -2, -3 /)
  A(3, :) = (/ -1,  1,  2 /)

  x       = (/ -4, -5,  2 /)

  ! y     = (/ -8,  0,  3 /)
  y = matmul(A, x)

  print "(a)", "A:"
  print "(3f6.1)", transpose(A)
  print *

  print "(a)", "x:"
  print "(3f6.1)", x
  print *

  print "(a)", "y:"
  print "(3f6.1)", y
  print *
end program linear_algebra


program qrtask
    implicit none
    integer, parameter :: n = 4
    real(8) :: durer(n, n) = reshape([16d0,  5d0,  9d0,  4d0, &
                                       3d0, 10d0,  6d0, 15d0, &
                                       2d0, 11d0,  7d0, 14d0, &
                                      13d0,  8d0, 12d0,  1d0], [n, n])
    real(8) :: q(n, n), r(n, n), qr(n, n), id(n, n), tau(n)
    integer, parameter :: lwork = 1024
    real(8) :: work(lwork)
    integer :: info, i, j

    q = durer
    call dgeqrf(n, n, q, n, tau, work, lwork, info)

    r = 0d0
    forall (i = 1:n, j = 1:n, j >= i) r(i, j) = q(i, j)

    call dorgqr(n, n, n, q, n, tau, work, lwork, info)

    qr = matmul(q, r)
    id = matmul(q, transpose(q))

    call show(4, durer, "A")
    call show(4, q, "Q")
    call show(4, r, "R")
    call show(4, qr, "Q*R")
    call show(4, id, "Q*Q'")
contains
    subroutine show(n, a, s)
        character(*) :: s
        integer :: n, i
        real(8) :: a(n, n)

        print *, s
        do i = 1, n
            print 1, a(i, :)
          1 format (*(F12.6,:,' '))
        end do
    end subroutine
end program


! 1D POISSON EQUATION SOLVER
! as presented in:
!
! "A novel lattice Boltzmann model for the Poisson equation"
! Zhenhua Chai, Baochang Shi, 2008, Applied Mathematical Modelling
!
! Ivan Pribec, Ljubljana, June 2015

! Solves the Poisson-Boltzman equation -> u';'; = k^2 * u

!#######################################################################
! PARAMETERS
!#######################################################################
module simParam
        ! precision (real kind)
    integer, parameter :: rKind = 4

        ! lattice weights
    real(kind = rKind), parameter ::  w(0:2)  = (/2.0/3.0, 1.0/6.0, 1.0/6.0/)
    real(kind = rKind), parameter :: ws(0:2)  = (/0.0, 0.5, 0.5/)
    real(kind = rKind), parameter ::   alpha  = 1.0/3.0

        ! lattice velocities
    integer, parameter :: e(0:2) = (/0,1,-1/)

        ! lattice dimension
    integer, parameter :: nx = 100

        ! maximum time value and data printing
    integer, parameter :: tMax  = 1000
    integer, parameter :: tPlot = 10

        ! lattice spacing and timestep
    real(kind = rKind), parameter :: dx = 0.01
    real(kind = rKind), parameter :: dt = 0.01
    real(kind = rKind), parameter :: c  = dx/dt

        ! relaxation time and diffusion coefficient
    real(kind = rKind), parameter :: tau   = 1.0
    real(kind = rKind), parameter :: omega = 1.0/tau
    real(kind = rKind), parameter :: D     = alpha*(c**2)*(0.5-tau)*dt

        ! steady state limit
    real(kind = rKind), parameter :: ssc = 0.0001

        ! poisson equation coefficient
    real(kind = rKind), parameter :: k = 27.79

end module simParam

!#######################################################################
! MAIN PROGRAM
!#######################################################################
program poisson1D
    use simParam
    implicit none

    real(kind = rKind) :: u(0:nx), u0(0:nx), diff(0:nx)
    real(kind = rKind) :: f(0:nx,0:2)
    real(kind = rKind) :: fEq
    integer :: x, i, t

        ! initialize u(x)
    u  = 0.0
    u0 = 1.0
    diff = abs(u-u0)

        ! boundary values u(0.0) = 1.0, u(1.0) = 1.0
    u(0)  = 1.0e0
    u(nx) = 1.0e0

        ! initialize f(x,i) to equilibrium
    do x = 0, nx
        do i = 0, 2
            f(x,i) = fEq(u(x),i)
        end do
    end do

        ! initialize time and counter
    t = 0
    call PrintData(f,u,t)

    ! ------------------------------------------------------------------
    ! MAIN (TIME) ITERATION LOOP - SOLVES POISSON EQUATION
    !-------------------------------------------------------------------
    do t = 1, tMax

            ! STREAMING
        f(1:nx,1)   = f(0:nx-1,1)   ! right e(1)
        f(0:nx-1,2) = f(1:nx,2)     ! left  e(2)

            ! BOUNDARY CONDITION
        u(0)  = 1.0e0
        u(nx) = 1.0e0

                ! Non-equilibrium extrapolation
            f(0,1)  = fEq(u(0),1)   + (1.0-omega)*(f(1,1)    - fEq(u(1),1))
            f(nx,2) = fEq(u(Nx),2)  + (1.0-omega)*(f(nx-1,2) - fEq(u(nx-1),2))
!~                 ! "Constant concentration"
!~             f(0,1)  = u(0) *(1.0-w(0)) - f(0,2)
!~             f(nx,2) = u(nx)*(1.0-w(0)) - f(nx,1)

            ! CALCULATE U (MACRO VARIABLE)
        do x = 0, nx
            u(x) = (f(x,1)+f(x,2))/(1.0-w(0))
        end do

        print*, sum(f)

            ! PRINT RESULTS
        if (mod(t,tPlot)==0) call PrintData(f,u,t)

            ! CALCULATE ABSOLUTE DIFFERENCE BETWEEN ITERATIONS
        diff = abs(u-u0)
        u0   = u
        if (all(diff < ssc)) then
            write(*,*) "Steady state condition was reached."
            exit
        end if

            ! COLLISION STEP
        do x = 0, nx
            do i = 0, 2
                f(x,i) = (1.0 - omega)*f(x,i) + omega*fEq(u(x),i) + dt*ws(i)*D*k*k*u(x)
            end do
        end do

    end do

    call PrintData(f,u,t)

    write(*,*) "Program finished."

end program poisson1D

!-----------------------------------------------------------------------
! equilibrium distribution function
!-----------------------------------------------------------------------
function fEq(u,i)
    use simParam, only: rKind, w
    implicit none

    real(kind = rKind) :: fEq, u
    integer :: i

    select case(i)
        case(0)
            fEq = (w(0)-1.0)*u
        case(1)
            fEq = w(1)*u
        case(2)
            fEq = w(2)*u
    end select

end function fEq

!-----------------------------------------------------------------------
! analytical solution for given Poisson equation
!-----------------------------------------------------------------------
function uSol(x)
    use simParam, only: rKind, k
    implicit none

    real(kind = rKind) :: uSol, x

    uSol = (exp(k) -1.0)/(exp(k)-exp(-k))*exp(-k*x) + &
         & (1.0-exp(-k))/(exp(k)-exp(-k))*exp(k*x)

end function uSol

!-----------------------------------------------------------------------
! prints results to file
!-----------------------------------------------------------------------
subroutine PrintData(f,u,t)
    use simParam, only: rKind, nx
    implicit none

    real(kind = rKind), intent(in) :: f(0:nx,0:2)
    real(kind = rKind), intent(in) :: u(0:nx)
    integer           , intent(in) :: t

    real(kind = rKind) :: uSol, ddx
    integer            :: x
    character(len=100) :: fileNum

    ddx = 1.0/real(nx)

        ! write iteration number to string
    write(fileNum,*) t
    fileNum = adjustl(fileNum)

        ! open file
    open(15,file=';iter_';//trim(fileNum)//';.dat';)

        ! write data to file for plotting
    write(15,*) "# x    uSol    uCalc  f(1)    f(2)    f(3)"
    do x = 0, nx
        write(15,*) x, uSol(real(x)*ddx), u(x), f(x,0), f(x,1), f(x,2)
    end do

        ! close file
    close(15)

    write(*,*) "Iteration = ", t

end subroutine PrintData


module funcs
implicit none
contains

real(kind=8) function g(x)
   real(kind=8) x

   g = 1 / (4*(log10( (0.0004/3.7) + (2.51/((10**5)*sqrt(x)))))**2)
end function g

end module funcs


!> fpm run --example math_signum
program demo_math_signum
    use forlab_math, only: signum

    print *, signum(1 - 2)
    print *, signum([0.0, 2.1])
    print *, signum((1.0, -2.0))

    !>    -1
    !>   0.00000000       1.00000000
    !>          (0.447213590,-0.894427180)

end program demo_math_signum


module rkf45_simd_mod
  implicit none

  contains
    pure subroutine rkf45_simd (y0, t0, tf, dt0, eps, t, dt, y, flag, num_steps)

        use rhs_simd_mod
        use iso_fortran_env, only: real64
        implicit none

        real(real64), intent(in) :: y0(:), t0, tf, dt0, eps
        real(real64), intent(out) :: t, dt, y(:)
        integer, intent(out) :: flag, num_steps

        real(real64) :: k1(size(y0))
        real(real64) :: k2(size(y0))
        real(real64) :: k3(size(y0))
        real(real64) :: k4(size(y0))
        real(real64) :: k5(size(y0))
        real(real64) :: k6(size(y0))

        real(real64) :: y_rk4_approx(size(y0))
        real(real64) :: y_rk5_approx(size(y0))
        real(real64) :: s
        real(real64) :: lte(size(y0))
        real(real64) :: maxlte
        real(real64) :: f(size(y0))

        integer, parameter :: maxiter = 10
        integer :: i

        num_steps = 0

        t = t0
        y = y0

        do while (t < tf)
          num_steps = num_steps + 1
          ! Initial guess at integration step size.
          dt = dt0
          ! Keep adjusting step size until we run out of iterations.
          do i = 1, maxiter

            ! A bunch of coefficients, taken from Hairer, Norsett, and Wanner (1993).

            call rhs_simd(t, y, f)
            k1 = dt * f

            call rhs_simd(t + 1.0d0/4.0d0*dt, y + 1.0d0/4.0d0*k1, f)
            k2 = dt * f

            call rhs_simd(t + 3.0d0/8.0d0*dt, y + 3.0d0/32.0d0*k1 &
                                                + 9.0d0/32.0d0*k2, &
                     f)
            k3 = dt * f

            call rhs_simd(t + 12.0d0/13.0d0*dt, y + 1932.0d0/2197.0d0*k1 &
                                                  - 7200.0d0/2197.0d0*k2 &
                                                  + 7296.0d0/2197.0d0*k3, &
                          f)
            k4 = dt * f

            call rhs_simd(t + dt, y + 439.0d0/216.0d0*k1 &
                                    - 8.0d0*k2 &
                                    + 3680.0d0/513.0d0*k3 &
                                    - 845.0d0/4104.0d0*k4, &
                          f)
            k5 = dt * f

            call rhs_simd(t + 1.0d0/2.0d0*dt, y - 8.0d0/27.0d0*k1 &
                                                + 2.0d0*k2 &
                                                - 3544.0d0/2565.0d0*k3 &
                                                + 1859.0d0/4104.0d0*k4 &
                                                - 11.0d0/40.0d0*k5, &
                          f)
            k6 = dt * f

            ! 4th-order approximation to y(t+dt)
            y_rk4_approx = y + 25.0d0/216.0d0*k1 &
                              + 1408.0d0/2565.0d0*k3 &
                              + 2197.0d0/4101.0d0*k4 &
                              - 1.0d0/5.0d0*k5
            ! 5th-order approximation to y(t+dt)
            y_rk5_approx = y + 16.0d0/135.0d0*k1 &
                              + 6656.0d0/12825.0d0*k3 &
                              + 28561.0d0/56430.0d0*k4 &
                              - 9.0d0/50.0d0*k5 &
                              + 2.0d0/55.0d0*k6

            ! Local truncation error between 4th- and 5th-order approximations of y(t+dt)
            lte = abs(y_rk5_approx - y_rk4_approx)
            maxlte = maxval(lte)

            ! Scalar by which to multiply step size to get new step size to satisfy error tolerance
            s = (eps / (2.0d0 * maxlte))**(1.0d0/4.0d0)

            ! If the local truncation error satisfies the tolerance
            ! requirements, then we're done!
            if (maxlte < eps) then
                flag = 0
                exit
            end if

            ! Adjust step size
            dt = dt*s

            ! Make sure we don't go past the final value
            if (t + dt > tf) then
                dt = tf - t
                cycle
            end if

          end do

          if (maxlte > eps) flag = -1

          t = t + dt
          y = y_rk5_approx

        end do

    end subroutine rkf45_simd

end module rkf45_simd_mod


      double precision function DCSEVL(X,A,N)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 DCSEVL Krogh  Changes to use M77CON
C>> 1990-11-29 DCSEVL CLL Changing name of single precision version.
C>> 1989-10-30 CLL
C>> 1985-08-02 DCSEVL Lawson  Initial code.
C
C EVALUATE THE N-TERM CHEBYSHEV SERIES A AT X. ADAPTED FROM
C R. BROUCKE, ALGORITHM 446, C.A.C.M., 16, 254 (1973).
C W. FULLERTON, C-3, LOS ALAMOS SCIENTIFIC LABORATORY.
C INSTALLED ON THE VAX BY DOLORES MONTANO, C-3, 5/80.
C 1989-10-30 CLL. Replaced name CSEVL with DCSEVL in calls to error
c     processing subroutines.  Commented out the test on X being in
c     [-1.0, 1.0].  Was giving unnecessary error msg when X was
c     slightly greater than 1.0 due to imprecise Cray DP arithmetic.
C
C       INPUT ARGUMENTS --
C X  [float,in]  VALUE AT WHICH THE SERIES IS TO BE EVALUATED.
C A  [float,in]  ARRAY OF N TERMS OF A CHEBYSHEV SERIES. IN EVAL-
C      UATING the series, ONLY HALF THE FIRST COEF IS SUMMED.
C N  [integer,in]  NUMBER OF TERMS IN ARRAY A.
C     ------------------------------------------------------------------
c--D replaces "?": ?CSEVL, ?ERM1
c     Also uses IERM1
C     ------------------------------------------------------------------
      integer I, N
      double precision A(N),X,TWOX,B0,B1,B2
C     ------------------------------------------------------------------
      IF (N .LT. 1) CALL IERM1('DCSEVL',1,0,
     *'NUMBER OF TERMS .LE. 0','ARG',N,'.')
      IF (N .GT. 1000) CALL IERM1('DCSEVL',2,0,
     *'NUMBER OF TERMS .GT. 1000','ARG',N,'.')
c     IF (X .LT. -1.D0 .OR. X .GT. 1.D0) CALL DERM1(
c    *'DCSEVL',3,0,'X OUTSIDE (-1,+1)','ARG',X,'.')
C
C
       TWOX = 2.0D0*X
       B1 = 0.D0
       B0=0.D0
       DO 10 I=N,1,-1
         B2=B1
         B1=B0
         B0 = TWOX*B1 - B2 + A(I)
 10    CONTINUE
C
       DCSEVL = 0.5D0 * (B0-B2)
C
       RETURN
       END


module slf_threshold

    use iso_fortran_env, only: r64 => real64
    implicit none

    real(r64), parameter, private :: pi = 4*atan(real(1,r64))

contains

    elemental real(r64) function THRSTEP(x) result(y)
        real(r64), intent(in) :: x
        if ( x .ge. 0 ) then
            y = 1.
        else
            y = 0.
        end if
    end function

    elemental real(r64) function THRLIN(x) result(y)
        real(r64), intent(in) :: x
        if ( x < -0.5_r64) then
            y = 0
        elseif ( x > 0.5_r64) then
            y = 1
        else
            y = x + 0.5_r64
        end if
    end function

    elemental real(r64) function THR2POLY(x,ord) result(y)
        real(r64), intent(in) :: x
        integer, intent(in), optional :: ord
        integer :: n
        real(r64) :: a, b

        n = 3
        if ( present(ord) )   n = ord

        a = THRLIN(0.5 + 2*x/n)
        b = THRLIN(0.5 - 2*x/n)

        y = (a**n - b**n + 1) / 2
    end function

    elemental real(r64) function THR4POLY(x,ord) result(y)
        real(r64), intent(in) :: x
        integer, intent(in), optional :: ord
        integer :: n
        real(r64) :: a, b, c

        n = 3
        if ( present(ord) )   n = ord

        a = THRLIN((3 + x*4)/2)
        b = 2*THRLIN(x) - 1
        c = THRLIN((3 - x*4)/2)

        y = (a**n - c**n + b*(2*n - abs(b)**(n-1)) + 2*n)/(4*n)

    end function

    elemental real(r64) function THRSIN(x) result(y)
        real(r64), intent(in) :: x
        real(r64) :: z

        z = 2*THRLIN(x / 2) - 1
        y =  (sin( pi * z) / pi + z + 1) / 2
    end function

    elemental real(r64) function THRATAN(x) result(y)
        real(r64), intent(in) :: x
        y = atan(x*pi) / pi + 0.5
    end function

    elemental real(r64) function thrsqrt(x) result(y)
        real(r64), intent(in) :: x
        y = 0.5_r64 +  x / sqrt( 1 + 4 * x**2 )
    end function

    elemental real(r64) function thrtanh(x) result(y)
        real(r64), intent(in) :: x
        y = 1d0 / ( 1d0 + exp(-4*x) )
    end function

end module


MODULE Factor_Mod

  ! MICHAEL B. PORTER 7/1/85
  !
  ! Based on TINVIT in EISPACK
  ! Gaussian elimination to factor a symmetric tridiagonal linear system
  !
  ! On input
  !    N is the order of the matrix
  !    d contains the diagonal elements of the input matrix
  !    e              subdiagonal
  !      in its last N-1 positions.  e(1) is arbitrary
  ! On output
  !    Rv1, Rv2, Rv3 and Rv4 contain the factored matrix

  IMPLICIT NONE
  INTEGER, PRIVATE :: i

  INTERFACE Factor
     MODULE PROCEDURE Factor_sngl, Factor_dble
  END INTERFACE Factor

CONTAINS

  SUBROUTINE Factor_sngl( N, d, e, Rv1, Rv2, Rv4 )

    INTEGER, INTENT( IN  ) :: N
    COMPLEX, INTENT( IN  ) :: d( N ), e( N )
    COMPLEX, INTENT( OUT ) :: Rv1( N ), Rv2( N ), Rv4( N )
    COMPLEX  :: U, V, XU

    ! LU decomposition without interchanges

    U = d( 1 )
    V = e( 2 )

    DO I = 2, N-1
       XU         = e( I ) / U
       Rv4( I   ) = XU
       Rv1( I-1 ) = 1.0 / U
       Rv2( I-1 ) = V
       U          = d( I ) - XU * V
       V          = e( I+1 )
    END DO

    ! following is same as above with I = N except V=e(N+1) is not used
    XU         = e( N ) / U
    Rv4( N   ) = XU
    Rv1( N-1 ) = 1.0 / U
    Rv2( N-1 ) = V
    U          = d(N) - XU * V

    IF ( U == 0.0 ) WRITE( *, * ) 'Singular matrix'
    Rv1( N ) = 1.0 / U
    Rv2( N ) = 0.0

  END SUBROUTINE Factor_sngl

  SUBROUTINE Factor_dble( N, d, e, Rv1, Rv2, Rv4 )

    INTEGER,          INTENT( IN  ) :: N
    COMPLEX (KIND=8), INTENT( IN  ) :: d( N ), e( N )
    COMPLEX (KIND=8), INTENT( OUT ) :: Rv1( N ), Rv2( N ), Rv4( N )
    COMPLEX (KIND=8) :: U, V, XU

    ! LU decomposition without interchanges

    U = d( 1 )
    V = e( 2 )

    DO I = 2, N-1
       XU         = e( I ) / U
       Rv4( I   ) = XU
       Rv1( I-1 ) = 1.0 / U
       Rv2( I-1 ) = V
       U          = d( I ) - XU * V
       V          = e( I+1 )
    END DO

    ! following is same as above with I = N except V=e(N+1) is not used
    XU         = e( N ) / U
    Rv4( N   ) = XU
    Rv1( N-1 ) = 1.0 / U
    Rv2( N-1 ) = V
    U          = d(N) - XU * V

    IF ( U == 0.0 ) WRITE( *, * ) 'Singular matrix'
    Rv1( N ) = 1.0 / U
    Rv2( N ) = 0.0

  END SUBROUTINE Factor_dble

END MODULE Factor_Mod