***********************************************************************
* This file provides routines to calculate the approximate arc length
* for a fictitious boundary component. The computation is based
* on a volume integration approach with a special trick:
*
* Let S denote the boundary curve of a fictitious boundary component.
* Then the drag- and lift-values are normally calculated by
*
*    int ( sigma * n ) ds
*     S
*
* with the stress tensor sigma=[grad(u)+p] and the normal vector n of
* S. Now replace sigma by n and obtain:
*
*    int ( n * n ) ds = int (1) ds = arclength(s)
*     S                  S
*
* because n has length 1. (To be more exact: we replaced the matrix
* sigma by the 2x2-matrix [n^T] and took the first component...
*                         [n^T]
*
* Using the Gauss formula we can obtain a (more or less) equivalent
* formulation using the volume integration and the characteristic
* function alpha of the fictitious boundary component V:
*
*    arclength(s) = int ( n * n ) ds = int (n * grad(alpha)) dx
*                    S                  V
*
* This is what we evaluate here.
*
* On the other hand the length of the boundary is calculated by
* adding the reconstructed interface of the fictitious boundary
* directly.
***********************************************************************

************************************************************************
* Calculates approximate arc length
*
* Volume integration, constant pressure
*
* In:
*  KVERT,KNPR,KMID,DCORVG,DCORMG - usual geometry data
*  ELE    - Element function used for volume integration
*  IFBC   - Number of the boundary component whose arc length should
*           be computed.
*           =0: compute sum of lengths of all fictitious boundary
*               components
*  IGEOM  - array [1..*] of integer
*  DGEOM  - array [1..*] of double
*           Integer- and double-precision parameter blocks with
*           geometry information. Passed to boundary
*           routines. Not used in this routine.
*
* Out:
*  DACLNV - Approximation of the arc length by volume integration
*  DACLNR - Approximation of the arc length by reconstructed interface
************************************************************************

      SUBROUTINE BDARCL (DCORVG,KVERT,DCORMG,KMID,KNPR,NEL,
     *                   NVE,NVT,NBCT,ELE,IFBC,DACLNV,DACLNR,LAMBDA,
     *                   IGEOM,DGEOM)

      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cerr.inc'
      INCLUDE 'cmem.inc'

      INCLUDE 'cbasictria.inc'

      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

      INCLUDE 'casmbly.inc'

      INCLUDE 'cmgadr.inc'

      INCLUDE 'cinidat.inc'

      INCLUDE 'ccub.inc'

C parameters
      DOUBLE PRECISION DCORVG(2,*),DCORMG(2,*),DGEOM(*)
      INTEGER KNPR(*),KVERT(NNVE,*),KMID(NNVE,*),IFBC,IGEOM(*)
      INTEGER NEL,NVE,NVT,NBCT
      DOUBLE PRECISION DACLNV,DACLNR,LAMBDA

C externals
      EXTERNAL ELE
      EXTERNAL CAINCP,CAVDCP,CAISCP,CADOCP,CAVDCE

C local variables

      INTEGER IINFO(1)

C Dummy variables

      DOUBLE PRECISION DU1(1),DU2(1),DP(1)

C Handle to DINFO-Array for integration routines.
C
C Structure:
C   double DACLNV - approximation of the arc length
C   double DACLNR - approximation of the arc length by
C                   reconstructed interface
C   double temp [5], used for calculation
C   double ALPHA [NU]

      INTEGER LDINFO

C Allocate memory for DINFO-arrays. We don't need IINFO!
C NU is taken from the COMMON block.

      CALL ZNEW (NU+8,1,LDINFO,'LDINFO')

c Use the vector dalpha as a test function in the weak formulation
c (only the difusion part is taken, should take even the
c convection but in featflow it seems to be ok) ...
c this needs to be checked in timedependent case

C Prepare the ALPHA-vector for all fict. boundary components;
C Use the INALPH-function from DRAGLIFT2.F:

      CALL INALPH (DWORK(L(LDINFO)+7),KNPR,KMID,NEL,NVT,NBCT,NU,0)

C Relaxate the alpha

      CALL RXALPH (DWORK(L(LDINFO)+7),DCORVG,KVERT,DCORMG,KMID,NEL,NVT,
     *             NU,IFBC,LAMBDA,IGEOM,DGEOM)

C IINFO holds the number of the fictitious boundary component

      IINFO(1) = IFBC

C Call the calculation routine; IINFO is a dummy parameter.
C Because this is a special volume integration not using velocity or
C pressure, we are using the pure user defined calculation
C routine here. DU1,DU2 and DP are dummies...

      CALL VOLINT (DU1,DU2,DP,KVERT,KMID,
     *    DCORVG,NEL,NVE,ELE,(IELT.EQ.2).OR.(IELT.EQ.3),8,
     *    IINFO, 1, DWORK(L(LDINFO)), NU+8,
     *    CAINCP,CAVDCE,CAVDCP,CAISCP,CADOCP,.TRUE.,0,0)
C     Call wrong!!!

C Obtain the values of the arc length

      DACLNV = DWORK(L(LDINFO))
      DACLNR = DWORK(L(LDINFO)+1)

C Release memory, finish

      CALL ZDISP (0,LDINFO,'LDINFO')

99999 END

************************************************************************
* Volume-integration callback-routines for arc length approximation:
************************************************************************

************************************************************************
* Initialisation
************************************************************************
      SUBROUTINE CAINCP (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                   ELE,BNONPR)

      IMPLICIT NONE

C parameters

      INTEGER NIINFO,IINFO(NIINFO),NDINFO
      LOGICAL BNONPR
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      EXTERNAL ELE

C initialise everything with 0

      DINFO(1) = 0D0
      DINFO(2) = 0D0

      END

************************************************************************
* Postprocessing
************************************************************************
      SUBROUTINE CADOCP (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                   ELE,BNONPR)

      IMPLICIT NONE

C parameters

      INTEGER NIINFO,IINFO(NIINFO),NDINFO
      LOGICAL BNONPR
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      EXTERNAL ELE

C nothing is done here

      END

************************************************************************
* Calculation on an element
************************************************************************
      SUBROUTINE CAVDCE (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                   IELE,ELE,BNONPR)

      IMPLICIT NONE

      INCLUDE 'cmem.inc'

      INCLUDE 'cbasictria.inc'
      INCLUDE 'ctria.inc'

C parameters

      INTEGER NIINFO,IINFO(NIINFO),NDINFO,IELE
      LOGICAL BNONPR
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      EXTERNAL ELE

C local variables

      INTEGER IFBC, IEDGE1, IEDGE2
      DOUBLE PRECISION X1,Y1, X2,Y2, LEN
      LOGICAL BFOUND

C Number of fictitious boundary component

      IFBC = IINFO(1)

C This performes the approximation by reconstruction of the interface.
C Call the reconstruction routine, reconstruct the points by 8
C approximation steps.

      CALL RCFBLI (DWORK(L(LCORVG)), KWORK(L(LVERT)), IELE, 8,
     *             IFBC, .FALSE., X1,Y1, IEDGE1, X2,Y2, IEDGE2,BFOUND,
     *             IGEOM,DGEOM)

C store the length

      IF (BFOUND) THEN
        LEN = DSQRT ((X2-X1)**2+(Y2-Y1)**2)
        DINFO(2) = DINFO(2)+LEN
      END IF

      END

************************************************************************
* Calculation of (partial) values in a cubature point
************************************************************************
      SUBROUTINE CAVDCP (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                   XX,YY,XX1,YY1,ICUBP,IELE,ELE,BNONPR)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'
      INCLUDE 'casmbly.inc'

C parameters

      INTEGER NIINFO,IINFO(NIINFO),NDINFO,IELE,ICUBP
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      DOUBLE PRECISION XX,YY,XX1,YY1
      LOGICAL BNONPR
      EXTERNAL ELE

C local variables

      DOUBLE PRECISION DAV,DAX,DAY,ALPH
      INTEGER I,IG,IFBC

C The ALPHA-vector is stored in DINFO(6..NU+6)

      DAV=0D0 ! VALUE
      DAX=0D0 ! X-der.
      DAY=0D0 ! Y-der.
      DO I=1,IDFL
        IG=KDFG(I)
        ALPH=DINFO(5+IG)
        DAV=DAV+ALPH*DBAS(KDFL(I),1)
        DAX=DAX+ALPH*DBAS(KDFL(I),2)
        DAY=DAY+ALPH*DBAS(KDFL(I),3)
      END DO

C save these values to DINFO for later use

      DINFO(3) = DAV
      DINFO(4) = DAX
      DINFO(5) = DAY

C Number of fictitious boundary component

      IFBC = IINFO(1)

C Try to obtain an approximation of the normal vector in the quadrature
C point and save that in DINFO

      CALL FBDNML (XX,YY,IFBC,DINFO(6),DINFO(7))

      END

************************************************************************
* Summing up the values from the cubature point to the values of
* interest.
************************************************************************
      SUBROUTINE CAISCP (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                   DETJ,ICUBP,IELE,OMEGA,
     *                   DU1V,DU1X,DU1Y,DU2V,DU2X,DU2Y,DPV)

      IMPLICIT NONE

      INCLUDE 'cmem.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'casmbly.inc'

C parameters

      INTEGER NIINFO,IINFO(NIINFO),NDINFO,ICUBP,IELE
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      DOUBLE PRECISION DETJ,OMEGA
      DOUBLE PRECISION DU1V,DU1X,DU1Y,DU2V,DU2X,DU2Y,DPV

C local variables

      DOUBLE PRECISION DAV,DAX,DAY,DN1,DN2,AH1

C get value/derivative

      DAV = DINFO(3)
      DAX = DINFO(4)
      DAY = DINFO(5)

C get the normal vector from the calculation routine above

      DN1 = DINFO(6)
      DN2 = DINFO(7)

C Oops, if user defined routine was not able to calculate that,
C we can't calculate the arc length...

      IF ((DN1.EQ.0D0).AND.(DN2.EQ.0D0)) GOTO 99999

C form the integrand: n*grad(alpha)

      AH1 = DN1*(-DAX)+DN2*(-DAY)

C Sum up to the integral

      DINFO(1)=DINFO(1)+AH1*OMEGA

99999 END


c
c-----------------------------------------------------------------------
c
       subroutine estdt(val,irr,mitot,mjtot,nvar,dx,dy,dtgrid,
     1                  lwidth,aux,naux)
c
       use amr_module, only : rinfinity
       implicit double precision (a-h, o-z)
       dimension val(nvar,mitot,mjtot), irr(mitot,mjtot)
       logical mine
       include "cuserdt.i"

c

       mine = .false.

       if (mine) then
       dtgrid = rinfinity ! initialize in case all solid cells
       speedmax =  0.d0
       do 20 j = lwidth+1, mjtot-lwidth
       do 10 i = lwidth+1, mitot-lwidth
          if (irr(i,j) .ne. -1) then
             rho  = val(1,i,j)
             u   = val(2,i,j)/rho
             v   = val(3,i,j)/rho
             etot  = val(4,i,j)
             velsq  = (u*u+v*v)
             p    = gamma1*(etot-.5d0*rho*velsq)
             c    = dsqrt(gamma*p/rho)
             speed = dsqrt(velsq) + c
             speedmax = max(speedmax,speed)
          endif
 10    continue
 20    continue
c
!!effh = (dx*dy)/(2.d0*dx + 2.d0*dy)
          effh = min(dx,dy)
          if (speedmax .gt. 0.d0) then
             dtgrid = cflcart * effh / speedmax
          endif

       else ! AG way
          dtgrid = -rinfinity ! initialize in case all solid cells
          do j = lwidth+1, mjtot-lwidth
          do i = lwidth+1, mitot-lwidth
            if (irr(i,j) .ne. -1) then
               rho  = val(1,i,j)
               u   = val(2,i,j)/rho
               v   = val(3,i,j)/rho
               etot  = val(4,i,j)
               velsq  = (u*u+v*v)
               p    = gamma1*(etot-.5d0*rho*velsq)
               c    = dsqrt(gamma*p/rho)
               sp1 = abs(u)+c
               sp2 = abs(v)+c
               dtgrid = max(dtgrid, (sp1/dx + sp2/dy))
            endif
          end do
          end do
          dtgrid = cflcart / dtgrid
       endif
c
c      write(*,*) "setting dt = ",dtgrid

       return
       end


! { dg-do compile }
! { dg-options "-O3 -floop-nest-optimize" }
SUBROUTINE rk_addtend_dry ( t_tend, t_tendf, t_save, rk_step, &
                            h_diabatic, mut, msft, ide, jde,  &
                            ims,ime, jms,jme, kms,kme,        &
                            its,ite, jts,jte, kts,kte)
   IMPLICIT NONE
   INTEGER ,  INTENT(IN   ) :: ide, jde, ims, ime, jms, jme, kms, kme, &
                               its, ite, jts, jte, kts, kte
   INTEGER ,  INTENT(IN   ) :: rk_step
   REAL , DIMENSION( ims:ime , kms:kme, jms:jme  ), &
       INTENT(INOUT) :: t_tend, t_tendf
   REAL , DIMENSION( ims:ime , kms:kme, jms:jme  ) , &
       INTENT(IN   ) ::  t_save, h_diabatic
   REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, msft
   INTEGER :: i, j, k
   DO j = jts,MIN(jte,jde-1)
   DO k = kts,kte-1
   DO i = its,MIN(ite,ide-1)
     IF(rk_step == 1)t_tendf(i,k,j) = t_tendf(i,k,j) +  t_save(i,k,j)
      t_tend(i,k,j) =  t_tend(i,k,j) +  t_tendf(i,k,j)/msft(i,j)  &
                                     +  mut(i,j)*h_diabatic(i,k,j)/msft(i,j)
   ENDDO
   ENDDO
   ENDDO
END SUBROUTINE rk_addtend_dry


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Written by: Anshuk Attri
C
C       Contact: contact@anshukattri.in
C       Website: www.anshukattri.in/research
C       GITHUB: github.com/aa-tree/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        SUBROUTINE CALC_FACTORIAL(NUM, FACTORIAL)

        IMPLICIT NONE

        INCLUDE 'common.dat'

        INTEGER NUM
        REAL*8 FACTORIAL

!       SUMMARY:
!
!       This routine computes factorial of a number.
!
!       VARIABLES:
!
!       NAME            TYPE            DESCRIPTION
!
!       NUM             Input(REAL*8)   The number that you want the
!                                        factorial of.
!
!       FACTORIAL       Output(REAL*8)  The factorial.
!
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        INTEGER I

        FACTORIAL=NUM

        DO I=1,NUM-1

            FACTORIAL=FACTORIAL*(NUM-I)

        END DO

        RETURN
        END


!** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!** See https://llvm.org/LICENSE.txt for license information.
!** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! Tests scalar mask for sum intrinsic.

	program p

	integer stuff(3,3)
	logical(4) msk1(3,3),msk2(3,3)
	logical(4) expect(2)
	logical(4) rslt(2)
	data expect /.true.,.true./
	integer atrue(3), afalse(3)
	integer sfalse(3), strue(3)

	do i=1,3
	do j=1,3
	stuff(i,j) = i
	enddo
	enddo

	msk1 = .true.
	msk2 = .false.

	atrue = sum(stuff,dim=1,mask=msk1)
	strue = sum(stuff,dim=1,mask=.true.)
	afalse = sum(stuff,dim=1,mask=msk2)
	sfalse = sum(stuff,dim=1,mask=.false.)
	rslt(1) = all(atrue .eq. strue)
	rslt(2) = all(afalse .eq. sfalse)
	call check(rslt,expect,2)

	end


c     DRSINT1F
c>> 2000-12-03 DRSINT1F Krogh  Declared WORK as WORK(1) in SINTF.
c>> 1994-11-02 DRSINT1F Krogh  Changes to use M77CON
c>> 1994-08-08 DRSINT1F Snyder Took '0' out of formats for C conversion
c>> 1993-05-05 DRSINT1F Krogh  Adjusted to simplify conversion to C.
c>> 1987-12-09 DRSINT1F Snyder Initial Code.
c--S replaces "?": DR?INT1f, ?INT1, ?INTF
c
c     DEMO DRIVER for 1 dimensional quadrature subprogram SINT1.
c
c     Compute the integral for X = 0.0 to X = PI of SIN(X), then
c     subtract 2.0 from the ANSWER.  The result should be zero.
c
c     The integrand is evaluated by the subprogram SINTF.
c
c
      real             A, B, ANSWER, WORK(1)
      integer IOPT(10)
10    format (/
     1' DRSINT1F:'/
     2' Compute the integral for X = 0.0 to X = PI of SIN(X), then'/
     3' subtract 2.0 from the ANSWER.  The result should be zero.')
20    format (/' ANSWER          =',G15.8/
     1         ' ERROR ESTIMATE  =',G15.8/
     2         ' STATUS FLAG     =',I6/
     3         ' FUNCTION VALUES =',I6)
c
      print 10
      A = 0.0E0
      B = 4.0E0 * ATAN(1.0E0)
      IOPT(2) = 10
      IOPT(3) = 0
      IOPT(4) = 0
c
      call SINT1 (A, B, ANSWER, WORK, IOPT)
      ANSWER = ANSWER - 2.0e0
      print 20, ANSWER, WORK(1), IOPT(1), IOPT(3)
      stop
      end
c   End of DRSINT1F

      subroutine SINTF (ANSWER, WORK, IFLAG)
c
c     Subroutine to provide integrand for SINT1.
c
      real             ANSWER, WORK(1)
      integer IFLAG
c
c     IFLAG is not used in this example.
c
      answer = sin(work(1))
      return
c
      end


program ch0918
    ! Alternative Format Specification Using a String
    implicit none

    integer :: t

    print *, ' '
    print *, ' Twelve times table'
    print *, ' '
    do t = 1, 12
        print  '(1x, i3, " * 12 = ", i3)', t, t*12
    end do
end program


!==========================================================================================================
!> @brief       MPI MPMD worker - parallel factorial calculation
!> @detail      This program is a part of MPI MPMD tutorial code.
!> @author      Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!> @date        01 January 2021
!> @version     0.1
!> @par         Copyright
!>              Copyright (c) 2018 by Ji-Hoon Kang. All rights reserved.
!> @par         License
!>              This project is release under the terms of the MIT License (see LICENSE in )
!==========================================================================================================

program sum

    use mpi_f08
    use mpmd

    implicit none

    integer(kind=4) :: nprocs, myrank
    integer(kind=4) :: i, ista, iend
    integer(kind=4) :: n, n_fact
    integer(kind=4) :: sum_local, sum_global, fact_global
    character(len=255) :: arg, command

    type(MPI_COMM)  :: local_comm, master_comm
    integer(kind=4) :: local_size, local_rank

    call MPI_Init()

    call MPI_Comm_size(MPI_COMM_WORLD, nprocs)
    call MPI_Comm_rank(MPI_COMM_WORLD, myrank)

    call mpmd_comm_init(MPI_COMM_WORLD, nprocs, myrank, local_comm, local_size, local_rank)
    call MPI_Comm_get_parent(master_comm)

    if (command_argument_count() /= 1) then
        call get_command_argument(0, command)
        if(local_rank.eq.0) print *, '[Sum] Usage:', trim(command), ' n (integer)'
        stop
    else
        call get_command_argument(0, command)
        call get_command_argument(1, arg)
        read(arg, *) n
    endif

    call para_range(1, n, local_size, local_rank, ista, iend)

    sum_local = 0
    do i = ista, iend
        sum_local = sum_local + i
    enddo

    call MPI_Reduce(sum_local, sum_global, 1, MPI_INTEGER, MPI_SUM, 0, local_comm)

    if(local_rank.eq.0) then
        print '(a2,a15,a8,i4,a3,i20)', ' [',trim(command),'] Sigma ',n,' = ',sum_global
        call MPI_Send(sum_global, 1, MPI_INTEGER, 0, 1, master_comm)
    endif

    call MPI_Finalize()

end program


! { dg-do  run }
! Take cshift through its paces to make sure no boundary
! cases are wrong.

module kinds
  integer, parameter :: sp = selected_real_kind(6) ! Single precision
end module kinds

module replacements
  use kinds
contains
  subroutine cshift_sp_3_v1 (array, shift, dim, res)
    integer, parameter :: wp = sp
    real(kind=wp), dimension(:,:,:), intent(in) :: array
    integer, intent(in) :: shift, dim
    real(kind=wp), dimension(:,:,:), intent(out) :: res
    integer :: i,j,k
    integer :: sh, rsh
    integer :: n
    integer :: n2, n3
    res = 0
    n3 = size(array,3)
    n2 = size(array,2)
    n1 = size(array,1)
    if (dim == 1) then
       n = n1
       sh = modulo(shift, n)
       rsh = n - sh
       do k=1, n3
          do j=1, n2
             do i=1, rsh
                res(i,j,k) = array(i+sh,j,k)
             end do
             do i=rsh+1,n
                res(i,j,k) = array(i-rsh,j,k)
             end do
          end do
       end do
    else if (dim == 2) then
       n = n2
       sh = modulo(shift,n)
       rsh = n - sh
       do k=1, n3
          do j=1, rsh
             do i=1, n1
                res(i,j,k) = array(i,j+sh, k)
             end do
          end do
          do j=rsh+1, n
             do i=1, n1
                res(i,j,k) = array(i,j-rsh, k)
             end do
          end do
       end do
    else if (dim == 3) then
       n = n3
       sh = modulo(shift, n)
       rsh = n - sh
       do k=1, rsh
          do j=1, n2
             do i=1, n1
                res(i,j,k) = array(i, j, k+sh)
             end do
          end do
       end do
       do k=rsh+1, n
          do j=1, n2
             do i=1, n1
                res(i,j, k) = array(i, j, k-rsh)
             end do
          end do
       end do
    else
       stop "Wrong argument to dim"
    end if
  end subroutine cshift_sp_3_v1
end module replacements

program testme
  use kinds
  use replacements
  implicit none
  integer, parameter :: wp = sp  ! Working precision
  INTEGER, PARAMETER :: n = 7
  real(kind=wp), dimension(:,:,:), allocatable :: a,b,c
  integer i, j, k
  real:: t1, t2
  integer, parameter :: nrep = 20

  allocate (a(n,n,n), b(n,n,n),c(n,n,n))
  call random_number(a)
  do k = 1,3
   do i=-3,3,2
     call cshift_sp_3_v1 (a, i, k, b)
     c = cshift(a,i,k)
     if (any (c /= b)) STOP 1
   end do
  end do
  deallocate (b,c)
  allocate (b(n-1,n-1,n-1),c(n-1,n-1,n-1))
  do k=1,3
     do i=-3,3,2
        call cshift_sp_3_v1 (a(1:n-1,1:n-1,1:n-1), i, k, b)
        c = cshift(a(1:n-1,1:n-1,1:n-1), i, k)
        if (any (c /= b)) STOP 2
     end do
  end do
end program testme


  module m_sort
    !! Module containing in-place and indirect routines to sort an array of numbers.
    !!
    !! Uses an introspective sort on a set of number. See this http://www.geeksforgeeks.org/know-your-sorting-algorithm-set-2-introsort-cs-sorting-weapon/ for more information
    !!
    !! To begin, a quicksort with a median of three pivot is used until the size of the array is less than 16.  At this point, an insertion sort is used to reduce cache overhead and tail recursion.
    !! Unfortunately, a quicksort is not ideal for sorted/almost sorted arrays or arrays with duplicate values.  Therefore if the number of iterations exceededs a threshold, a heapsort is used instead.
    !! This provides a robust sorting algorithm that is still very fast for almost sorted arrays.
    !!
    !! In this implementation, the quicksort and heapsort are unstable sorts. A stable merge sort is therefore provided as an alternative but it has an order(N) memory overhead.
    !!
    !! Often, the numbers wish to be maintained in their given order, so with an O(N) memory overhead we can sort an integer array instead by calling argsort()
    !!
    !! See [[sort]] and [[argSort]] for more information.
  use variableKind

  implicit none

  private

  public  :: sort

  interface sort
    !!Use an in-place introspection sort on an array of numbers
    !!
    !!Example usage
    !!```fortran
    !!program sortTest
    !!use variableKind, only: i32, r64
    !!use m_strings, only: str
    !!use m_allocate, only: allocate
    !!use m_random, only: rngInteger, rngNormal
    !!use m_arrays, only: arange, isSorted
    !!use m_sort, only: sort
    !!real(r64),allocatable :: d1D(:)
    !!integer(i32),allocatable :: i1D(:)
    !!integer(i32) :: N
    !!
    !!N = 10000
    !!write(*,'(a)') 'In-place sort a 10000 length array of random double precision numbers'
    !!call allocate(d1D,N)
    !!call rngNormal(d1D)
    !!call sort(d1D)
    !!write(*,'(a)') 'Double array is sorted? '//str(isSorted(d1D))
    !!write(*,'(a)') 'In-place sort a 10000 length array of random integers''
    !!call allocate(i1D,N)
    !!call rngInteger(i1D)
    !!call sort(i1D)
    !!write(*,'(a)') 'Integer array is sorted? '//str(isSorted(i1D))
    !!end program
    !!```
    module subroutine sort_i1D(this, stable)
      !! Interfaced with [[sort]]
      integer(i32) :: this(:)
      logical, optional :: stable
    end subroutine
    module subroutine sort_id1D(this, stable)
      !! Interfaced with [[sort]]
      integer(i64) :: this(:)
      logical, optional :: stable
    end subroutine
    module subroutine sort_r1D(this, stable)
      !! Interfaced with [[sort]]
      real(r32) :: this(:)
      logical, optional :: stable
    end subroutine
    module subroutine sort_d1D(this, stable)
      !! Interfaced with [[sort]]
      real(r64) :: this(:)
      logical, optional :: stable
    end subroutine
  end interface
  private :: sort_i1D, sort_id1D, sort_r1D, sort_d1D

  public :: argSort

  interface argSort
    !!Use an indirect introspection sort on an array of numbers
    !!
    !!Example usage
    !!```fortran
    !!program argSortTest
    !!use variableKind
    !!use m_strings, only: str
    !!use m_random, only: rngInteger, rngNormal
    !!use m_arrays, only: arange, isSorted
    !!use m_Sort, only: argSort
    !!real(r64),allocatable :: d1D(:)
    !!integer(i32),allocatable :: i1D(:)
    !!integer(i32),allocatable :: indx(:)
    !!integer(i32) :: i, N
    !!
    !!N=10000
    !!call allocate(indx, N)
    !!call arange(indx, 1, N)
    !!call allocate(d1D, N)
    !!call rngNormal(d1D)
    !!call argSort(d1D, indx)
    !!write(*,'(a)') 'Double array is indirectly sorted? '//str(isSorted(d1D(indx)))
    !!
    !!call arange(indx, 1, N)
    !!call allocate(i1D,N)
    !!call rngInteger(i1D)
    !!call argSort(i1D, indx)
    !!write(*,'(a)') 'Integer array is indirectly sorted? '//str(isSorted(i1D(indx)))
    !!end program
    !!```
    module subroutine argSort_i1D(this, i, stable)
      !! Interfaced with [[argSort]]
      integer(i32) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Index to sort
      logical, optional :: stable !! Stable sort?
    end subroutine
    module subroutine argSort_id1D(this, i, stable)
      !! Interfaced with [[argSort]]
      integer(i64) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Index to sort
      logical, optional :: stable !! Stable sort?
    end subroutine
    module subroutine argSort_r1D(this, i, stable)
      !! Interfaced with [[argSort]]
      real(r32) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Index to sort
      logical, optional :: stable !! Stable sort?
    end subroutine
    module subroutine argSort_d1D(this, i, stable)
      !! Interfaced with [[argSort]]
      real(r64) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Index to sort
      logical, optional :: stable !! Stable sort?
    end subroutine
  end interface
  private :: argSort_i1D, argSort_id1D, argSort_r1D, argSort_d1D

  private :: introsort
  interface introsort
    !! Perform an in-place introspective sort on an array
    module subroutine introsort_r1D(this)
      !! Interfaced with [[introsort]]
      real(r32) :: this(:) !! 1D array
    end subroutine
    module subroutine introsort_d1D(this)
      !! Interfaced with [[introsort]]
      real(r64) :: this(:) !! 1D array
    end subroutine
    module subroutine introsort_i1D(this)
      !! Interfaced with [[introsort]]
      integer(i32) :: this(:) !! 1D array
    end subroutine
    module subroutine introsort_id1D(this)
      !! Interfaced with [[introsort]]
      integer(i64) :: this(:) !! 1D array
    end subroutine
  end interface

  private :: argIntrosort
  interface argintrosort
    !! Perform an indirect introsort on an array
    module subroutine argintrosort_r1D(this,i)
      !! Interfaced with [[argIntrosort]]
      real(r32) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Sort this integer key
    end subroutine
    module subroutine argintrosort_d1D(this,i)
      !! Interfaced with [[argIntrosort]]
      real(r64) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Sort this integer key
    end subroutine
    module subroutine argintrosort_i1D(this,i)
      !! Interfaced with [[argIntrosort]]
      integer(i32) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Sort this integer key
    end subroutine
    module subroutine argintrosort_id1D(this,i)
      !! Interfaced with [[argIntrosort]]
      integer(i64) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Sort this integer key
    end subroutine
  end interface

  interface MergeSort
    !! Perform an in-place stable merge sort on an array
    module subroutine mergesort_r1D(this)
      !! Interf aced with [[mergesort]]
      real(r32):: this(:) !! 1D array
    end subroutine
    module subroutine mergesort_d1D(this)
      !! Interfaced with [[mergesort]]
      real(r64) :: this(:) !! 1D array
    end subroutine
    module subroutine mergesort_i1D(this)
      !! Interfaced with [[mergesort]]
      integer(i32) :: this(:) !! 1D array
    end subroutine
    module subroutine mergesort_id1D(this)
      !! Interfaced with [[mergesort]]
      integer(i64) :: this(:) !! 1D array
    end subroutine
  end interface

  interface argMergeSort
    !! Perform an indirect stable merge sort on an array
    module subroutine argmergesort_r1D(this,i)
      !! Interfaced with [[argmergesort]]
      real(r32) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Sort this integer key
    end subroutine
    module subroutine argmergesort_d1D(this,i)
      !! Interfaced with [[argmergesort]]
      real(r64) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Sort this integer key
    end subroutine
    module subroutine argmergesort_i1D(this,i)
      !! Interfaced with [[argmergesort]]
      integer(i32) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Sort this integer key
    end subroutine
    module subroutine argmergesort_id1D(this,i)
      !! Interfaced with [[argmergesort]]
      integer(i64) :: this(:) !! 1D array
      integer(i32) :: i(:) !! Sort this integer key
    end subroutine
  end interface

  public :: insertionSort

  interface insertionsort
    !! Perform an in-place insertion sort on an array
    module subroutine insertionsort_r1D(this,iLeft,iRight)
      !! Interfaced with [[insertionsort]]
      real(r32) :: this(:) !! 1D array
      integer(i32) :: iLeft !! Left index
      integer(i32) :: iRight !! Right index
    end subroutine
    module subroutine insertionsort_d1D(this,iLeft,iRight)
      !! Interfaced with [[insertionsort]]
      real(r64) :: this(:) !! 1D array
      integer(i32) :: iLeft !! Left index
      integer(i32) :: iRight !! Right index
    end subroutine
    module subroutine insertionsort_i1D(this,iLeft,iRight)
      !! Interfaced with [[insertionsort]]
      integer(i32) :: this(:) !! 1D array
      integer(i32) :: iLeft !! Left index
      integer(i32) :: iRight !! Right index
    end subroutine
    module subroutine insertionsort_id1D(this,iLeft,iRight)
      !! Interfaced with [[insertionsort]]
      integer(i64) :: this(:) !! 1D array
      integer(i32) :: iLeft !! Left index
      integer(i32) :: iRight !! Right index
    end subroutine
  end interface
  private :: insertionsort_r1D, insertionsort_d1D, insertionsort_i1D, insertionsort_id1D

  public :: argInsertionsort

  interface argInsertionsort
    !! Perform an indirect insertion sort on an array
    module subroutine argInsertionsort_r1D(this,indx,iLeft,iRight)
      !! Interfaced with [[arginsertionsort]]
      real(r32) :: this(:) !! 1D array
      integer(i32) :: indx(:) !! Sort this integer key
      integer(i32) :: iLeft !! Left index
      integer(i32) :: iRight !! Right index
    end subroutine
    module subroutine argInsertionsort_d1D(this,indx,iLeft,iRight)
      !! Interfaced with [[arginsertionsort]]
      real(r64) :: this(:) !! 1D array
      integer(i32) :: indx(:) !! Sort this integer key
      integer(i32) :: iLeft !! Left index
      integer(i32) :: iRight !! Right index
    end subroutine
    module subroutine argInsertionsort_i1D(this,indx,iLeft,iRight)
      !! Interfaced with [[arginsertionsort]]
      integer(i32) :: this(:) !! 1D array
      integer(i32) :: indx(:) !! Sort this integer key
      integer(i32) :: iLeft !! Left index
      integer(i32) :: iRight !! Right index
    end subroutine
    module subroutine argInsertionsort_id1D(this,indx,iLeft,iRight)
      !! Interfaced with [[arginsertionsort]]
      integer(i64) :: this(:) !! 1D array
      integer(i32) :: indx(:) !! Sort this integer key
      integer(i32) :: iLeft !! Left index
      integer(i32) :: iRight !! Right index
    end subroutine
  end interface
  private :: argInsertionsort_r1D, argInsertionsort_d1D, argInsertionsort_i1D, argInsertionsort_id1D

  private :: heapsort
  interface heapsort
    !! Perform an in-place heapsort on an array
    module subroutine heapsort_r1D(this)
      !! Interfaced with heapsort()
      real(r32) :: this(0:) !! 1D array
    end subroutine
    module subroutine heapsort_d1D(this)
      !! Interfaced with heapsort()
      real(r64):: this(0:) !! 1D array
    end subroutine
    module subroutine heapsort_i1D(this)
      !! Interfaced with heapsort()
      integer(i32):: this(0:) !! 1D array
    end subroutine
    module subroutine heapsort_id1D(this)
      !! Interfaced with heapsort()
      integer(i64):: this(0:) !! 1D array
    end subroutine
  end interface

  private :: argHeapsort
  interface argHeapsort
    !! Perform an indirect heapsort on an array
    module subroutine argHeapsort_r1D(this,indx)
      !! Interfaced with argHeapsort()
      real(r32) :: this(:) !! 1D array
      integer(i32) :: indx(0:) !! Sort this integer key
    end subroutine
    module subroutine argHeapsort_d1D(this,indx)
      !! Interfaced with argHeapsort()
      real(r64):: this(:) !! 1D array
      integer(i32) :: indx(0:) !! Sort this integer key
    end subroutine
    module subroutine argHeapsort_i1D(this,indx)
      !! Interfaced with argHeapsort()
      integer(i32):: this(:) !! 1D array
      integer(i32) :: indx(0:) !! Sort this integer key
    end subroutine
    module subroutine argHeapsort_id1D(this,indx)
      !! Interfaced with argHeapsort()
      integer(i64):: this(:) !! 1D array
      integer(i32) :: indx(0:) !! Sort this integer key
    end subroutine
  end interface

  end module


subroutine bisection ( f, fatol, itmax, xl, xr, xatol, xrtol )
!
!*******************************************************************************
!
!! BISECTION carries out the bisection algorithm.
!
!
!  Modified:
!
!    19 September 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real FATOL, the absolute error tolerance for F(X).
!
!    Input, integer ITMAX, the maximum number of steps allowed.
!
!    Input, real X1, X2, two points where the function differs in sign.
!
!    Input, real XATOL, absolute error tolerance for the root.
!
  implicit none
!
  real*8 f
  real*8 fatol
  real*8 fxl
  real*8 fxm
  real*8 fxr
  integer iterate
  integer itmax
  real*8 x_ave
  !real*8 x1
  !real*8 x2
  real*8 xatol
  real*8 xl
  real*8 xm
  real*8 xr
  real*8 xrtol
!
  write ( *, * ) ' '
  write ( *, * ) ' '
  write ( *, * ) 'The bisection method'
  write ( *, * ) ' '
  write ( *, * ) ' '

  !xl = x1
  !xr = x2
  !call f ( xl, fxl, 0 )
  !call f ( xr, fxr, 0 )
  fxl = f(xl)
  fxr = f(xr)
!
!  Check for change of sign.
!
  if ( fxl * fxr > 0.0E+00 ) then
    write ( *, * ) ' '
    write ( *, * ) 'WARNING:'
    write ( *, * ) ' '
    write ( *, * ) '  This method requires a change of sign '
    write ( *, * ) '  interval, but your function does NOT change '
    write ( *, * ) '  sign over the given interval, so this method '
    write ( *, * ) '  cannot be used.'
    write ( *, * ) ' '
    write ( *, * ) 'SUGGESTION:'
    write ( *, * ) ' '
    write ( *, * ) '  Try a different method;'
    write ( *, * ) '  Try changing X1 or X2;'
    write ( *, * ) '  Perhaps your function F(X) is wrong.'
    return
  end if

  write ( *, * ) ' Step           Left          Middle         Right'

  iterate = 0

  write ( *, * ) ' '
  write ( *, '(i4,'' X'',g16.8,16x,f16.8)' ) iterate,  xl,  xr
  write ( *, '(4x,''FX'',g16.8,16x,g16.8)' )          fxl, fxr
!
!  Take another step of the iteration.
!
  do

    iterate = iterate + 1
    x_ave = ( abs ( xr ) + abs ( xl ) ) / 2.0E+00

    if ( iterate > itmax ) then
      write ( *, * ) ' '
      write ( *, * ) '  Maximum number of steps taken.'
      exit
    end if

    if ( abs ( xr - xl ) <= xatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of the X interval.'
      exit
    end if

    if ( abs ( xr - xl ) <= xrtol * x_ave ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of the X interval.'
      exit
    end if

    if ( abs ( fxl ) <= fatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of |F(X)|.'
      exit
    end if

    if ( abs ( fxr ) <= fatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of |F(X)|.'
      exit
    end if
!
!  Compute the next iterate.
!
    xm = ( xl + xr ) / 2.0E+00
    !call f ( xm, fxm, 0 )
    fxm = f(xm)

    write ( *, * ) ' '
    write ( *, '(i4,'' X'',3f16.8)' ) iterate,  xl,  xm,  xr
    write ( *, '(4x,''FX'',3g16.8)' )          fxl, fxm, fxr
!
!  Prepare for the next step.
!
    if ( fxl * fxm > 0.0E+00 ) then
      xl = xm
      fxl = fxm
    else
      xr = xm
      fxr = fxm
    end if

  end do

  return
end
subroutine brent ( f, fatol, itmax, xb, xc, xatol, xrtol )
!
!*******************************************************************************
!
!! BRENT implements the Brent bisection-based zero finder.
!
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization without Derivatives,
!    Prentice Hall, 1973.
!
!  Modified:
!
!    20 September 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real FATOL, an absolute error tolerance for the function
!    value of the root.  If an approximate root X satisfies
!      ABS ( F ( X ) ) <= FATOL, then X will be accepted as the
!    root and the iteration will be terminated.
!
!    Input, integer ITMAX, the maximum number of steps allowed.
!
!    Input, real X1, X2, two points at which the function differs in sign.
!
!    Input, real XATOL, XRTOL, absolute and relative error tolerances
!    for the root.
!
  implicit none
!
  real*8 f
  real*8 d
  real*8 e
  real*8 fatol
  real*8 fxa
  real*8 fxb
  real*8 fxc
  integer iterate
  integer itmax
  real*8 p
  real*8 q
  real*8 r
  real*8 s
  real*8 x_ave
  real*8 x_int
  !real*8 x1
  !real*8 x2
  real*8 xa
  real*8 xb
  real*8 xc
  real*8 xm
  real*8 xatol
  real*8 xrtol
!
!  Initialization.
!
  write ( *, * ) ' '
  write ( *, * ) 'Brent''s Method'
  write ( *, * ) ' '
  write ( *, * ) 'Step      XA            XB             F(XA)         F(XB)'
  write ( *, * ) ' '

  iterate = 0

  xa = xb !x1
  xb = xc !x2
  !call f ( xa, fxa, 0 )
  !call f ( xb, fxb, 0 )
  fxa = f(xa)
  fxb = f(xb)
!
!  Check for change of sign.
!
  if ( fxa * fxb > 0.0E+00 ) then
    write ( *, * ) ' '
    write ( *, * ) 'WARNING:'
    write ( *, * ) ' '
    write ( *, * ) '  This method requires a change of sign '
    write ( *, * ) '  interval, but your function does NOT change '
    write ( *, * ) '  sign over the given interval, so this method '
    write ( *, * ) '  cannot be used.'
    write ( *, * ) ' '
    write ( *, * ) 'SUGGESTION:'
    write ( *, * ) ' '
    write ( *, * ) '  Try a different method;'
    write ( *, * ) '  Try changing X1 or X2;'
    write ( *, * ) '  Perhaps your function F(X) is wrong.'
    return
  end if

  xc = xa
  fxc = fxa
  d = xb - xa
  e = d

  do

    write ( *, '(i4,2x,2g16.8,2g14.6)' ) iterate, xb, xc, fxb, fxc

    iterate = iterate + 1

    if ( iterate > itmax ) then
      write ( *, * ) ' '
      write ( *, * ) '  Maximum number of steps taken.'
      exit
    end if
!
!  If necessary, swap data so that |F(XB)| <= |F(XC)|.
!
    if ( abs ( fxc ) < abs ( fxb ) ) then
      call r_swap ( xb, xc )
      call r_swap ( fxb, fxc )
    end if
!
!  XM is the halfwidth of the current change-of-sign interval.
!
    x_int = xc - xb
    x_ave = ( abs ( xc ) + abs ( xb ) ) / 2.0E+00

    xm = 0.5E+00 * ( xc - xb )

    if ( abs ( x_int ) <= xatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of the X interval.'
      exit
    end if

    if ( abs ( x_int ) <= xrtol * x_ave ) then
      write ( *, * ) ' '
      write ( *, * ) '  Relative convergence of the X interval.'
      exit
    end if

    if ( abs ( fxb ) <= fatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of |F(X)|.'
      exit
    end if
!
!  See if a bisection is forced.
!
    if ( abs ( e ) < xatol .or. abs ( fxa ) <= abs ( fxb ) ) then

      d = xm
      e = d

    else

      s = fxb / fxa
!
!  Linear interpolation.
!
      if ( xa == xc ) then

        p = 2.0E+00 * xm * s
        q = 1.0E+00 - s
!
!  Inverse quadratic interpolation.
!
      else

        q = fxa / fxc
        r = fxb / fxc
        p = s * ( 2.0E+00 * xm * q * ( q - r ) - ( xb - xa ) * ( r - 1.0E+00 ) )
        q = ( q - 1.0E+00 ) * ( r - 1.0E+00 ) * ( s - 1.0E+00 )

      end if

      if ( p > 0.0E+00 ) then
        q = - q
      else
        p = - p
      end if

      s = e
      e = d

      if ( 2.0E+00 * p >= 3.0E+00 * xm * q - abs ( xatol * q ) .or. &
           p >= abs ( 0.5E+00 * s * q ) ) then
        d = xm
        e = d
      else
        d = p / q
      end if

    end if
!
!  Save in XA, FXA the previous values of XB, FXB.
!
    xa = xb
    fxa = fxb
!
!  Compute the next iterate.
!
    if ( abs ( d ) > xatol ) then
      xb = xb + d
    else if ( xm > 0.0E+00 ) then
      xb = xb + xatol
    else if ( xm <= 0.0E+00 ) then
      xb = xb - xatol
    end if

    !call f ( xb, fxb, 0 )
    fxb = f(xb)
!
!  If the new FXB has the same sign as FXC, then replace XC by XA.
!
    if ( ( fxb > 0.0E+00 .and. fxc > 0.0E+00 ) .or. &
         ( fxb < 0.0E+00 .and. fxc < 0.0E+00 ) ) then
      xc = xa
      fxc = fxa
      d = xb - xa
      e = d
    end if

  end do

  return
end

subroutine muller_r ( f, fatol, itmax, x1, x2, x3, xatol, xrtol )
!
!*******************************************************************************
!
!! MULLER_R carries out Muller's method restricted to real roots.
!
!
!  Modified:
!
!    18 September 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real FATOL, the absolute error tolerance for F(X).
!
!    Input, integer ITMAX, the maximum number of steps allowed.
!
!    Input, real X1, X2, X3, three points to start the iteration.
!
!    Input, real XATOL, absolute error tolerance for the root.
!
  implicit none
!
  real*8 f
  double precision a
  double precision b
  double precision c
  double precision discrm
  real*8 fatol
  real*8 fminus
  real*8 fplus
  real*8 fxmid
  real*8 fxnew
  real*8 fxold
  integer iterate
  integer itmax
  real*8 x_ave
  real*8 x_inc
  real*8 x1
  real*8 x2
  real*8 x3
  real*8 xatol
  real*8 xlast
  real*8 xmid
  real*8 xminus
  real*8 xnew
  real*8 xold
  real*8 xplus
  real*8 xrtol
!
  xnew = x1
  xmid = x2
  xold = x3
  !call f ( xnew, fxnew, 0 )
  !call f ( xmid, fxmid, 0 )
  !call f ( xold, fxold, 0 )
  fxnew = f(xnew)
  fxmid = f(xmid)
  fxold = f(xold)

  write ( *, * ) ' '
  write ( *, * ) ' '
  write ( *, * ) 'Muller''s method (real root version)'
  write ( *, * ) ' '
  write ( *, * ) 'Note that the existence of a nearby complex root'
  write ( *, * ) 'is suggested when the value of the discriminant'
  write ( *, * ) 'is negative.'
  write ( *, * ) ' '
  write ( *, * ) ' '
  write ( *, * ) 'Iteration          x                 fx            disc'
  write ( *, * ) ' '

  iterate = 0
  discrm = 0.0E+00
  write ( *, '(1x,i6,f20.10,f20.10,f20.10)' ) iterate, xnew, fxnew

  if ( abs ( fxnew ) < fatol ) then
    write ( *, * ) ' '
    write ( *, * ) '|F(X)| is below the tolerance.'
    return
  end if

  do

    if ( abs ( fxnew ) >= abs ( fxmid ) ) then
      call r_swap ( xnew, xmid )
      call r_swap ( fxnew, fxmid )
    end if

    xlast = xnew
    iterate = iterate + 1

    if ( iterate > itmax ) then
      write ( *, * ) ' '
      write ( *, * ) '  Maximum number of steps taken.'
      exit
    end if

    a = dble ( ( xmid - xnew ) * ( fxold - fxnew ) &
             - ( xold - xnew ) * ( fxmid - fxnew ) )

    b = dble ( ( xold - xnew )**2 * ( fxmid - fxnew ) &
             - ( xmid - xnew )**2 * ( fxold - fxnew ) )

    c = dble ( ( xold - xnew ) * ( xmid - xnew ) * ( xold - xmid ) * fxnew )

    xold = xmid
    xmid = xnew
!
!  Apply the quadratic formula to get roots XPLUS and XMINUS.
!
    discrm = b**2 - 4.0E+00 * a * c

    if ( discrm <= 0.0E+00 ) then
      discrm = 0.0E+00
    end if

    if ( a == 0.0E+00 ) then
      write ( *, * ) ' '
      write ( *, * ) 'The algorithm has broken down.'
      write ( *, * ) 'The quadratic coefficient A is zero.'
      exit
    end if

    xplus = xnew + sngl ( ( - b + sqrt ( discrm ) ) / ( 2.0E+00 * a ) )

    !call f ( xplus, fplus, 0 )
    fplus = f(xplus)

    xminus = xnew + sngl ( ( - b - sqrt ( discrm ) ) / ( 2.0E+00 * a ) )

    !call f ( xminus, fminus, 0 )
    fminus = f(xminus)

!
!  Take whichever of the two quadratic roots is closest to a root of
!  the function.
!
    if ( abs ( fminus ) < abs ( fplus ) ) then
      xnew = xminus
    else
      xnew = xplus
    end if

    fxold = fxmid
    fxmid = fxnew
    !call f ( xnew, fxnew, 0 )
    fxnew = f(xnew)

    write ( *, '(1x,i6,f20.10,f20.10,f20.10)' ) iterate, xnew, fxnew, discrm
!
!  Check for convergence.
!
    x_ave = ( abs ( xnew ) + abs ( xmid ) + abs ( xold ) ) / 3.0E+00
    x_inc = xnew - xmid

    if ( abs ( x_inc ) <= xatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of the X increment.'
      exit
    end if

    if ( abs ( x_inc ) <= xrtol * x_ave ) then
      write ( *, * ) ' '
      write ( *, * ) '  Relative convergence of the X increment.'
      exit
    end if

    if ( abs ( fxnew ) <= fatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of |F(X)|.'
      exit
    end if

  end do

  return
end

subroutine newton ( f, df, fatol, itmax, x1, xatol, xrtol )
!
!*******************************************************************************
!
!! NEWTON carries out Newton's method.
!
!
!  Modified:
!
!    20 September 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real FATOL, the absolute error tolerance for F(X).
!
!    Input, integer ITMAX, the maximum number of steps allowed.
!
!    Input, real X1, a point where the iteration begins.
!
!    Input, real XATOL, absolute error tolerance for the root.
!
  implicit none
!
  integer, parameter :: MAX_ROOT = 20
!
  real*8 f
  real*8 df
  real*8 fatol
  real*8 fprime
  real*8 fx
  integer i
  integer iroot
  character isay
  integer iterat
  integer itmax
  real*8 roots(MAX_ROOT)
  real*8 x_ave
  real*8 x_inc
  real*8 x1
  real*8 xatol
  real*8 xnew
  real*8 xold
  real*8 xrtol
!
  roots(1:MAX_ROOT) = 0.0E+00

  iroot = 0

10 continue

  iroot = iroot + 1
  if ( iroot > MAX_ROOT ) then
    return
  end if

  write ( *, * ) ' '
  write ( *, * ) ' '
  write ( *, * ) ' Newton''s method'
  write ( *, * ) ' '
  write ( *, * ) ' '
  write ( *, * ) 'Iteration            X                    FX'
  write ( *, * ) ' '

  iterat = 0
  xnew = x1
  !call f ( xnew, fx, 0 )
  fx = f(xnew)
  write ( *, '(i6,f20.10,f20.10)' ) iterat, xnew, fx

  if ( abs ( fx ) <= fatol ) then
    write ( *, * ) ' '
    write ( *, * ) '|F(X)| is below the tolerance.'
    return
  end if

  do

    iterat = iterat + 1

    if ( iterat > itmax ) then
      write ( *, * ) ' '
      write ( *, * ) '  Maximum number of steps taken.'
      return
    end if

    xold = xnew
    !call f ( xold, fx, 0 )
    fx = f(xold)
    !call f ( xold, fprime, 1 )
    fprime = df(xold)

    do i = 1, iroot - 1

      if ( xold - roots(i) == 0.0E+00 ) then
        write ( *, * ) ' '
        write ( *, * ) 'The algorithm has broken down.'
        write ( *, * ) 'A zero divisor was computed.'
        exit
      end if

      fprime = fprime - fx / ( xold - roots(i) )

    end do

    if ( fprime == 0.0E+00 ) then
      write ( *, * ) ' '
      write ( *, * ) 'The algorithm has broken down.'
      write ( *, * ) 'A zero divisor was computed.'
      exit
    end if

    x_inc = - fx / fprime
    xnew = xold + x_inc

    !call f ( xnew, fx, 0 )
    fx = f(xnew)

    write ( *, '(i6,f20.10,f20.10)' ) iterat, xnew, fx
!
!  Check for acceptance of function value or interval
!
    x_ave = abs ( xnew ) + abs ( xold )

    if ( abs ( x_inc ) <= xatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of the X increment.'
      exit
    end if

    if ( abs ( x_inc ) <= xrtol * x_ave ) then
      write ( *, * ) ' '
      write ( *, * ) '  Relative convergence of the X increment.'
      exit
    end if

    if ( abs ( fx ) <= fatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of |F(X)|.'
      exit
    end if

  end do

  return
end

subroutine secant ( f, fatol, itmax, x1, x2, xatol, xrtol )
!
!*******************************************************************************
!
!! SECANT carries out the secant algorithm.
!
!
!  Modified:
!
!    18 September 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real FATOL, the absolute error tolerance for F(X).
!
!    Input, integer ITMAX, the maximum number of steps allowed.
!
!    Input, real X1, X2, two points at which the iteration begins.
!
!    Input, real XATOL, absolute error tolerance for the root.
!
  implicit none
!
  real*8 f
  real*8 fatol
  real*8 fx
  real*8 fxnew
  real*8 fxold
  integer iterate
  integer itmax
  real*8 x_ave
  real*8 x_inc
  real*8 x1
  real*8 x2
  real*8 xatol
  real*8 x
  real*8 xnew
  real*8 xold
  real*8 xrtol
!
  write ( *, * ) ' '
  write ( *, * ) ' '
  write ( *, * ) 'The secant method:'
  write ( *, * ) ' '
  write ( *, * ) ' '
  write ( *, * ) 'Step       X          FX'
  write ( *, * ) ' '

  iterate = -1
  xold = x1
  !call f ( xold, fxold, 0 )
  fxold = f(xold)
  write ( *, '(i4,2g16.8)' ) iterate, xold, fxold

  if ( abs ( fxold ) <= fatol ) then
    write ( *, * ) ' '
    write ( *, * ) '|F(X)| is below the tolerance.'
    return
  end if

  iterate = 0
  x = x2
  !call f ( x, fx, 0 )
  fx = f(x)
  write ( *, '(i4,2g16.8)' ) iterate, x, fx

  if ( abs ( fx ) <= fatol ) then
    write ( *, * ) ' '
    write ( *, * ) '  Absolute convergence of |F(X)|.'
    return
  end if

  do

    iterate = iterate + 1

    if ( iterate > itmax ) then
      write ( *, * ) ' '
      write ( *, * ) '  Maximum number of steps taken.'
      exit
    end if

    x_inc = x - xold
    x_ave = ( abs ( x ) + abs ( xold ) ) / 2.0E+00

    if ( abs ( x_inc ) <= xatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of the X increment.'
      exit
    end if

    if ( abs ( x_inc ) <= xrtol * x_ave ) then
      write ( *, * ) ' '
      write ( *, * ) '  Relative convergence of the X increment.'
      exit
    end if

    if ( abs ( fx ) <= fatol ) then
      write ( *, * ) ' '
      write ( *, * ) '  Absolute convergence of |F(X)|.'
      exit
    end if
!
!  Compute the next iterate.
!
    xnew = ( fxold * x - fx * xold ) / ( fxold - fx )
    !call f ( xnew, fxnew, 0 )
    fxnew = f(xnew)

    write ( *, '(i4,2g16.8)' ) iterate, xnew, fxnew
!
!  Prepare for the next step.
!
    xold = x
    fxold = fx

    x = xnew
    fx = fxnew

    end do

  return
end

subroutine r_swap ( x, y )
!
!*******************************************************************************
!
!! R_SWAP switches two real values.
!
!
!  Modified:
!
!    30 November 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real X, Y.  On output, the values of X and
!    Y have been interchanged.
!
  implicit none
!
  real*8 x
  real*8 y
  real*8 z
!
  z = x
  x = y
  y = z

  return
end


      FUNCTION CSEDRESS(DENBULK,WRSPO,VDRO,VDR,VDRC,IOPT)
      INTEGER::IOPT
      REAL::CSEDRESS,BULKDEN,DENBULK,TMP,WRSPO,VDRO,VDR,VDRC
C CHANGE RECORD
C
C
C **  CALCULATES SURFACE EROSION RATE OF COHESIVE
C **  SEDIMENT AS A FUNCTION OF BED BULK DENSITY
C **  IOPT=1  BASED ON
C **
C **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
C **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
C **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
C **  IOPT=2  BASED ON J. M. HAMRICK'S MODIFICATION OF
C **
C **  SANFORD, L.P., AND J. P. Y. MAA, 2001: A UNIFIED EROSION FORMULATI
C **  FOR FINE SEDIMENT, MARINE GEOLOGY, 179, 9-23.
C
      IF(IOPT.EQ.1)THEN
        BULKDEN=0.001*DENBULK    ! *** PMC
        IF(BULKDEN.LE.1.065)THEN
          CSEDRESS=0.62
        ELSE
          TMP=0.198/(BULKDEN-1.0023)
          TMP=EXP(TMP)
          CSEDRESS=6.4E-4*(10.**TMP)
        ENDIF
      ELSEIF(IOPT.EQ.2)THEN
        CSEDRESS=WRSPO*(1.+VDRO)/(1.+VDR)
      ELSEIF(IOPT.EQ.3)THEN
        CSEDRESS=WRSPO*(1.+VDRO)/(1.+VDRC)
      ELSEIF(IOPT.GE.99)THEN
        CSEDRESS=WRSPO
      ENDIF

      RETURN
      END


!***********************************************************************
!                                                                      *
      SUBROUTINE NCHARG
!                                                                      *
!   This routine evaluates the nuclear charge density, and stores it   *
!   in the  common  array  ZDIST .                                     *
!                                                                      *
!   Call(s) to: [LIB92]: ES.                                           *
!                                                                      *
!   Written by Farid A Parpia, at Oxford   Last updated: 09 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE def_C,           ONLY: pi,  z, precis
      USE grid_C
      USE npar_C
      USE ncdist_C
      USE tatb_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE es_I
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
      REAL(DOUBLE) :: C, A, CBA, PI2, ABC, ABC2, ABC3, S2MCBA, S3MCBA, EN,&
         ZNORM, EXTRM, ZDISTI
      LOGICAL :: FORM1, FORM2
!-----------------------------------------------
!
!
!   Initialize array to zero
!
      ZDIST(:N) = 0.0D00
!
!   Fermi charge distribution
!
      IF (NPARM == 2) THEN
         C = PARM(1)
         A = PARM(2)
         CBA = C/A
         PI2 = PI*PI
         ABC = A/C
         ABC2 = ABC*ABC
         ABC3 = ABC2*ABC
         CALL ES ((-CBA), S2MCBA, S3MCBA)
         EN = 1.0D00 + PI2*ABC2 - 6.0D00*ABC3*S3MCBA
         ZNORM = 3.0D00*Z/(4.0D00*PI*EN*C**3)
         FORM1 = .TRUE.
         FORM2 = .FALSE.
         DO I = 1, N
            IF (FORM1) THEN
               EXTRM = DEXP((R(I)-C)/A)
               ZDIST(I) = ZNORM/(1.0D00 + EXTRM)
               IF (1.0D00/EXTRM <= PRECIS) THEN
                  FORM1 = .FALSE.
                  FORM2 = .TRUE.
               ENDIF
            ELSE IF (FORM2) THEN
               ZDISTI = ZNORM*DEXP((-(R(I)-C)/A))
               IF (DABS(ZDISTI) > 0.0D00) THEN
                  ZDIST(I) = ZDISTI
               ELSE
                  MTP = I
                  EXIT
               ENDIF
            ENDIF
         END DO
      ENDIF
!
      RETURN
!
      END SUBROUTINE NCHARG


      FUNCTION CSNDZEQ(SNDDIA,GPDIASED,TAUR,TAUB,SNDDMX,DEP,
     &    IOPT,SSG,WS)
C
C CHANGE RECORD
C
C
C **  CALCULATES NEAR BED REFERENCE CONCENTRATION REFERENCE HEIGHT
C **  IOPT=1  BASED ON
C **
C **  GARCIA, M., AND G. PARKER, 1991: ENTRAINMENT OF BED SEDIMENT
C **  INTO SUSPENSION, J. HYDRAULIC ENGINEERING, 117, 414-435.
C
      IF(IOPT.EQ.1)THEN
        CSNDZEQ=0.05
      ENDIF
C
C **  IOPT=2  BASED ON
C **
C **  SMITH, J. D., AND S. R. MCLEAN, 1977: SPATIALLY AVERAGED FLOW
C **  OVER A WAVY SURFACE, J. GEOPHYSICAL RESEARCH, 82, 1735-1746.
C
      IF(IOPT.EQ.2)THEN
        TMPVAL=26.3*SNDDMX*(TAUB-TAUR)/GPDIASED
        TMPVAL=TMPVAL*SNDDIA/SNDDMX
        TMPVAL=TMPVAL/DEP
        CSNDZEQ=MAX(TMPVAL,0.01)
      ENDIF
C
C **  IOPT=3  BASED ON
C **
C **  VAN RIJN, L. C., 1984: SEDIMENT TRANSPORT, PART II: SUSPENDED
C **  LOAD TRANSPORT, J. HYDRAULIC ENGINEERING, 110, 1623-1641.
C
      IF(IOPT.EQ.3)THEN
        REY=1.E4*SNDDIA*( (9.8*(SSG-1.))**0.333 )
        IF(REY.LE.10.) TAURS=(4.*WS/REY)**2
        IF(REY.GT.10.) TAURS=0.016*WS*WS
        VAL=(TAUB/TAURS)-1.
C
C        VAL=(TAUB/TAUR)-1.
C
        VAL=MAX(VAL,0.)
        VAL1=1.-EXP(-0.5*VAL)
        VAL1=0.11*VAL1*(25.-VAL)
        ZEQ1=0.5*VAL1*(DEP**0.7)*(SNDDMX**0.3)
        ZEQ1=ZEQ1/DEP
        CSNDZEQ=MAX(ZEQ1,0.01)
      ENDIF
      RETURN
      END


use plantfem
implicit none

type(IO_)::f
type(Random_) :: random
type(Console_) :: console
complex(complex64),allocatable :: t(:), omega(:),Fw(:),ft(:),&
    Fw512(:),Fw256(:),Fw128(:),Fw064(:),&
    Ft512(:),Ft256(:),Ft128(:),Ft064(:)
integer(int32) :: i, mode_id

call console%log("Low-pass mode = 0, high-pass mode=1")
mode_id = fint(console%readline())

t  = linspace([0.0d0,30.0d0], 1024)
omega  = linspace([0.0d0,30.0d0/1024.0d0], 1024)
Fw = zeros(1024)
Fw512 = zeros(1024)
Fw256 = zeros(1024)
Fw128 = zeros(1024)
Fw064 = zeros(1024)
Ft512 = zeros(1024)
Ft256 = zeros(1024)
Ft128 = zeros(1024)
Ft064 = zeros(1024)

ft = zeros(1024)

! create impulse
do i=400,600
    ft(i) = 1.0d0
enddo

fw = fft(ft)

if(mode_id==0)then
    ! Low-pass filter
    fw512(1:512) = Fw(1:512)
    fw256(1:256) = Fw(1:256)
    fw128(1:128) = Fw(1:128)
    fw064(1:64) = Fw(1:64)
else
    ! High-pass filter
    fw256(512-256:512+256) = Fw(512-256:512+256)
    fw128(512-128:512+128) = Fw(512-128:512+128)
    fw064(512-64 :512+64 ) = Fw(512-64 :512+64 )
endif

ft = ifft(Fw)
ft512 = ifft(Fw512)
ft256 = ifft(Fw256)
ft128 = ifft(Fw128)
ft064 = ifft(Fw064)

call f%open("impulse100.txt","w")
call f%write(real(t(:) ),real(Ft(:) ))
call f%close()
call f%open("impulse512.txt","w")
call f%write(real(t(:) ),real(Ft512(:) ))
call f%close()
call f%open("impulse256.txt","w")
call f%write(real(t(:) ),real(Ft256(:) ))
call f%close()
call f%open("impulse128.txt","w")
call f%write(real(t(:) ),real(Ft128(:) ))
call f%close()
call f%open("impulse064.txt","w")
call f%write(real(t(:) ),real(Ft064(:) ))
call f%close()

call f%plot("impulse100.txt","with lines")
call f%plot("impulse512.txt","with lines")
call f%plot("impulse256.txt","with lines")
call f%plot("impulse128.txt","with lines")
call f%plot("impulse064.txt","with lines")

end


module rbf_wc2
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FOUR, FIVE, EIGHT, PI
    use type_radial_basis_function,  only: radial_basis_function_t
    use mod_rbf_tools
    implicit none

    !>  Wendland's C2 compactly supported RBF
    !!
    !!  @author Eric Wolf
    !!  @date  8/4/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(radial_basis_function_t), public :: wc2_rbf

    contains

        procedure   :: init
        procedure   :: compute
        procedure   :: compute_grad

    end type wc2_rbf
    !********************************************************************************

contains

    !>
    !!
    !!  @author Eric Wolf
    !!  @date  8/4/2017
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(wc2_rbf),  intent(inout)  :: self

        !
        ! Set function name
        !
        call self%set_name("wc2_rbf")

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date  8/4/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute(self,eval_node,support_node,support_radius) result(val)
        class(wc2_rbf),     intent(inout)   :: self
        real(rk),               intent(in)      :: eval_node(3)
        real(rk),               intent(in)      :: support_node(3)
        real(rk),               intent(in)      :: support_radius(3)

        real(rk)                                :: val

        real(rk) :: radius_norm

        !2D case ?
        !radius_norm = sqrt((val(1)-support_val(1))**TWO+(val(2)-support_val(2))**TWO)

        !3D Case - how to handle dimensionality more generally?

        radius_norm = compute_radius_norm(eval_node, support_node, support_radius)
        if (radius_norm < ONE) then

            val = (ONE-radius_norm)**FOUR*(FOUR*radius_norm+ONE)
        else
            val = ZERO
        end if

    end function compute
    !**********************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date  8/4/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_grad(self,eval_node,support_node,support_radius) result(val)
        class(wc2_rbf),     intent(inout)   :: self
        real(rk),               intent(in)      :: eval_node(3)
        real(rk),               intent(in)      :: support_node(3)
        real(rk),               intent(in)      :: support_radius(3)

        real(rk)                                :: val(3)

        real(rk) :: radius_norm
        real(rk) :: radius_norm_grad(3)

        !2D case ?
        !radius_norm = sqrt((val(1)-support_val(1))**TWO+(val(2)-support_val(2))**TWO)

        !3D Case - how to handle dimensionality more generally?
        radius_norm         = compute_radius_norm(eval_node, support_node, support_radius)
        radius_norm_grad    = compute_radius_norm_grad(eval_node, support_node, support_radius)

        if (radius_norm < ONE) then

            val =( -FOUR*(ONE-radius_norm)**THREE*(FOUR*radius_norm+ONE) + (ONE-radius_norm)**FOUR*(FOUR))*radius_norm_grad

        else
            val = ZERO
        end if

    end function compute_grad
    !**********************************************************************************

end module rbf_wc2


MODULE m_gradYlm
   IMPLICIT NONE

CONTAINS

  ! Derivative routine from Spex.
  ! Calculates derivative of a function with scalar argument lying on a muffin-tin mesh
  subroutine Derivative(f, itype, atoms, df)

    use m_types

     type(t_atoms), intent(in)  :: atoms

     integer,       intent(in)  :: itype
     real,          intent(in)  :: f(atoms%jri(itype))
     real,          intent(out) :: df(atoms%jri(itype))
     real                       :: h, r, d21, d32, d43, d31, d42, d41, df1, df2, s
     real                       :: y0, y1, y2
     integer                    :: i, n

     n = atoms%jri(itype)
     h = atoms%dx(itype)
     r = atoms%rmsh(1, itype)

     ! use Lagrange interpolation of 3rd order (and averaging) for points 3 to n
     d21 = r * (exp(h)-1) ; d32 = d21 * exp(h) ; d43 = d32 * exp(h)
     d31 = d21 + d32      ; d42 = d32 + d43
     d41 = d31 + d43
     df(1) =   d31*d41 / (d21*d32*d42) * f(2) + ( -1.0/d21 - 1.0/d31 - 1.0/d41) * f(1)&
    &        - d21*d41 / (d31*d32*d43) * f(3) + d21*d31 / (d41*d42*d43) * f(4)
     df(2) = - d32*d42 / (d21*d31*d41) * f(1) + (  1.0/d21 - 1.0/d32 - 1.0/d42) * f(2)&
    &        + d21*d42 / (d31*d32*d43) * f(3) - d21*d32 / (d41*d42*d43) * f(4)
     df1   =   d32*d43 / (d21*d31*d41) * f(1) - d31*d43 / (d21*d32*d42) * f(2) +&
    &  ( 1.0/d31 + 1.0/d32 - 1.0/d43 ) * f(3) + d31*d32 / (d41*d42*d43) * f(4)
     do i = 3, n - 2
        d21 = d32 ; d32 = d43 ; d43 = d43 * exp(h)
        d31 = d42 ; d42 = d42 * exp(h)
        d41 = d41 * exp(h)
        df2   = - d32*d42 / (d21*d31*d41) * f(i-1) + ( 1.0/d21 - 1.0/d32 - 1.0/d42) * f(i) + &
    &             d21*d42 / (d31*d32*d43) * f(i+1) - d21*d32 / (d41*d42*d43) * f(i+2)
        df(i) = ( df1 + df2 ) / 2
        df1   = d32*d43 / (d21*d31*d41) * f(i-1) - d31*d43 / (d21*d32*d42) * f(i) +&
    &    ( 1.0/d31 + 1.0/d32 - 1.0/d43 ) * f(i+1) + d31*d32 / (d41*d42*d43) * f(i+2)
     enddo
     df(n-1) = df1
     df(n)   = - d42*d43 / (d21*d31*d41) * f(n-3) + d41*d43 / (d21*d32*d42) * f(n-2) -&
    &            d41*d42 / (d31*d32*d43) * f(n-1) + ( 1.0/d41 + 1.0/d42 + 1.0/d43 ) * f(n)
     ! for first two points use Lagrange interpolation of second order for log(f(i))
     ! or, as a fall-back, Lagrange interpolation with the conditions f(1), f(2), f(3), f'(3).
     s = sign(1.0,f(1))
     if(sign(1.0,f(2)) /= s .or. sign(1.0,f(3))  /= s .or. any(f(:3) == 0)) then
        d21   = r * (exp(h)-1)
        d32   = d21 * exp(h)
        d31   = d21 + d32
        s     = df(3) / (d31*d32) - f(1) / (d21*d31**2) + f(2) / (d21*d32**2) - f(3) / (d31**2*d32) - f(3) / (d31*d32**2)
        df(1) = - (d21+d31) / (d21*d31) * f(1) + d31 / (d21*d32) * f(2) - d21 / (d31*d32) * f(3) + d21*d31 * s

        df(2) = - (d21-d32) / (d21*d32) * f(2) - d32 / (d21*d31) * f(1) + d21 / (d31*d32) * f(3) - d21*d32 * s
     else
        y0    = log(abs(f(1)))
        y1    = log(abs(f(2)))
        y2    = log(abs(f(3)))
        df(1) = ( - 3*y0/2 + 2*y1 - y2/2 ) * f(1) / (h*r)
        df(2) = (y2-y0)/2                  * f(2) / (h*r*exp(h))
     endif
  end subroutine Derivative

   SUBROUTINE gradYlm(atoms, r2FshMt, r2GrFshMt)
   ! Based on work for juphon by C. Gerhorst.
  !---------------------------------------------------------------------------------------------------------------------------------
  !> @author
  !> Christian-Roman Gerhorst, Forschungszentrum Jülich: IAS1 / PGI1
  !>
  !> @brief
  !> Calculates the spherical harmonic expansion coefficients of the muffin-tin gradient applied to an arbitrary function multiplied
  !> by $r^2$. The resulting gradient expansion coefficients are multiplied by a factor $r^2$.
  !>
  !> @note
  !> The ingoing function is assumed to be multiplied with $r^2$. The outgoing resulting function is also multiplied by $r^2$.
  !>
  !> @param[in]  atoms     : Contains atoms-related quantities; definition of its members in types.F90 file.
  !> @param[in]  r2FshMt   : Lattice harmonic coefficients of muffin-tin quantity multiplied by a factor of r**2.
  !> @param[out] r2GrFshMt : Spherical harmonic coefficients of muffin-tin quantity's gradient multiplied by a factor of r**2
  !---------------------------------------------------------------------------------------------------------------------------------

    use m_constants, only : fpi_const, ImagUnit
    use m_gaunt, only : gaunt1
    use m_types
    USE m_grdchlh

    ! Type parameter
    ! ***************
    type(t_atoms),                     intent(in)  :: atoms

    ! Array parameters
    ! ****************
    complex,       allocatable,        intent(in)  :: r2FshMt(:, :, :)
    complex,       allocatable,        intent(out) :: r2GrFshMt(:, :, :, :)

    ! Local Scalar Variables
    ! **********************
    ! pfac     : Prefactor
    ! tGaunt   : Gaunt coefficient
    ! itype    : Loop index for atom types
    ! ieqat    : Loop index for equivalent atoms
    ! iatom    : Loop index for all atoms
    ! imesh    : Loop index for radial mesh point
    ! mqn_m    : Magnetic quantum number m
    ! oqn_l    : Orbital quantum number l
    ! mqn_mpp  : Magnetic quantum number double primed to index the natural coordinates
    ! lmInput  : Collective index for orbital and magnetic quantum number used for input function
    ! lmOutput : Collective index for orbital and magnetic quantum number used for output function
    real                                           :: pfac
    real                                           :: tGaunt
    integer                                        :: itype
    integer                                        :: ieqat
    integer                                        :: iatom
    integer                                        :: imesh
    integer                                        :: mqn_m
    integer                                        :: oqn_l
    integer                                        :: mqn_mpp
    integer                                        :: lmOutput
    integer                                        :: lmInput

    ! Local Array Variables
    ! *********************
    ! rDerFlhMtre  : Real part of the radial derrivative applied to the incoming fuction coefficients
    ! rDerFlhMtim  : Imaginary part of the radial derrivative applied to the incoming fuction coefficients
    ! rDerFlhMt    : Radial derrivative of the incoming fuction
    ! r2GrFshMtNat : Expansion coefficients of the muffin-tin gradient applied to the incoming function. The coefficients are given
    !                in natural coordinates and multiplied by $r^2$
    real,          allocatable                     :: r2FshMtre(:)
    real,          allocatable                     :: r2FshMtim(:)
    real,          allocatable                     :: rDerFshMtre(:)
    real,          allocatable                     :: rDerFshMtim(:)
    real,          allocatable                     :: rDerJunk(:)
    complex,       allocatable                     :: rDerFshMt(:)
    complex,       allocatable                     :: r2GrFshMtNat(:, :, :, :)
    !Matrix syntax idea from http://stackoverflow.com/questions/3708307/how-to-initialize-two-dimensional-arrays-in-fortran
    complex, dimension(3, 3)  :: Tmatrix !no parameter anymore since the init below is not OK for this
    Tmatrix = transpose(reshape([                                                          &
                                                                   & cmplx(1 / sqrt(2.), 0), cmplx(0, 0), cmplx(-1 / sqrt(2.), 0), &
                                                                   & -ImagUnit / sqrt(2.), cmplx(0, 0), -ImagUnit / sqrt(2.), &
                                                                   & cmplx(0, 0), cmplx(1, 0), cmplx(0, 0) &
                                                                   & ], [3, 3] )) !< see my notes

    ! Initialization of additionaly required arrays.
    allocate( r2GrFshMt(atoms%jmtd, ( atoms%lmaxd + 2 )**2, atoms%nat, 3) )
    allocate( r2GrFshMtNat(atoms%jmtd, ( atoms%lmaxd + 2 )**2, atoms%nat, 3) )
    allocate( r2FshMtre(atoms%jmtd), r2FshMtim(atoms%jmtd), rDerFshMtre(atoms%jmtd), rDerFshMtim(atoms%jmtd), rDerJunk(atoms%jmtd), rDerFshMt(atoms%jmtd) )

    r2FshMtre(:) = 0.
    r2FshMtim(:) = 0.
    rDerFshMtre(:) = 0.
    rDerFshMtim(:) = 0.
    rDerFshMt(:) = 0.
    r2GrFshMt = cmplx(0., 0.)
    r2GrFshMtNat = cmplx(0., 0.)

    pfac = sqrt( fpi_const / 3 )
    do mqn_mpp = -1, 1
      iatom = 0
      do itype = 1, atoms%ntype
        do ieqat = 1, atoms%neq(itype)
          iatom = iatom + 1
          do oqn_l = 0, atoms%lmax(itype)
            do mqn_m = -oqn_l, oqn_l

              ! l + 1 block
              if ( abs(mqn_m - mqn_mpp) <= oqn_l + 1 ) then
                lmOutput = ( oqn_l + 1 ) * ( oqn_l + 2 ) + 1 + mqn_m - mqn_mpp
                lmInput = oqn_l * ( oqn_l + 1 ) + 1 + mqn_m
                r2FshMtre(:) = 0.
                r2FshMtim(:) = 0.
                rDerFshMtre(:) = 0.
                rDerFshMtim(:) = 0.
                ! This is also a trade of between storage and performance, because derivative is called redundantly, maybe store it?
                r2FshMtre(:)=real(r2FshMt(:, lmInput, itype))
                r2FshMtim(:)=aimag(r2FshMt(:, lmInput, itype))
                call Derivative( r2FshMtre, itype, atoms, rDerFshMtre )
                call Derivative( r2FshMtim, itype, atoms, rDerFshMtim )

                tGaunt = Gaunt1( oqn_l + 1, oqn_l, 1, mqn_m - mqn_mpp, mqn_m, -mqn_mpp, atoms%lmaxd + 1 )
                do imesh = 1, atoms%jri(itype)
                  rDerFshMt(imesh) = cmplx(rDerFshMtre(imesh), rDerFshMtim(imesh))
                  r2GrFshMtNat(imesh, lmOutput, iatom, mqn_mpp + 2) = r2GrFshMtNat(imesh, lmOutput, iatom, mqn_mpp + 2) + pfac *   &
                    & (-1)**mqn_mpp * tGaunt &
                    & * (rDerFshMt(imesh) - ((oqn_l + 2)* r2FshMt(imesh, lmInput, iatom) / atoms%rmsh(imesh, itype)))
                end do ! imesh
              end if ! ( abs(mqn_m - mqn_mpp) <= oqn_l + 1 )

              ! l - 1 block
              if ( abs(mqn_m - mqn_mpp) <= oqn_l - 1 ) then
                lmInput = oqn_l * ( oqn_l + 1 ) + 1 + mqn_m
                lmOutput = (oqn_l - 1) * oqn_l + 1 + mqn_m - mqn_mpp
                r2FshMtre(:) = 0.
                r2FshMtim(:) = 0.
                rDerFshMtre(:) = 0.
                rDerFshMtim(:) = 0.
                ! This is also a trade of between storage and performance, because derivative is called redundantly, maybe store it?
                r2FshMtre(:)=real(r2FshMt(:, lmInput, itype))
                r2FshMtim(:)=aimag(r2FshMt(:, lmInput, itype))
                call Derivative( r2FshMtre, itype, atoms, rDerFshMtre )
                call Derivative( r2FshMtim, itype, atoms, rDerFshMtim )

                tGaunt = Gaunt1( oqn_l - 1, oqn_l, 1, mqn_m - mqn_mpp, mqn_m, -mqn_mpp, atoms%lmaxd + 1 )
                do imesh = 1, atoms%jri(itype)
                  rDerFshMt(imesh) = cmplx(rDerFshMtre(imesh), rDerFshMtim(imesh))
                  r2GrFshMtNat(imesh, lmOutput, iatom, mqn_mpp + 2) = r2GrFshMtNat(imesh, lmOutput, iatom, mqn_mpp + 2) + pfac *   &
                    & (-1)**mqn_mpp * tGaunt * ( rDerFshMt(imesh) + ( (oqn_l - 1) * r2FshMt(imesh, lmInput, iatom)&
                    & / atoms%rmsh(imesh, itype) ) )
                enddo ! imesh
              end if ! ( abs(mqn_m - mqn_mpp) <= oqn_l - 1 )
            end do ! mqn_m
          end do ! oqn_l
        end do ! ieqat
      end do ! itype
    end do ! mqn_mpp

    ! Conversion from natural to cartesian coordinates
    iatom = 0
    do itype = 1, atoms%ntype
      do ieqat = 1, atoms%neq(itype)
        iatom = iatom + 1
        do oqn_l = 0, atoms%lmax(itype) + 1
          do mqn_m = -oqn_l, oqn_l
            lmOutput = oqn_l * (oqn_l + 1) + 1 + mqn_m
            do imesh = 1, atoms%jri(itype)
              r2GrFshMt(imesh, lmOutput, iatom, 1:3) = matmul( Tmatrix(1:3, 1:3), r2GrFshMtNat(imesh, lmOutput, iatom, 1:3) )
            end do ! imesh
          end do ! mqn_m
        end do ! oqn_l
      end do ! ieqat
    end do ! itype

   END SUBROUTINE gradYlm

   SUBROUTINE divYlm(gradMtx, gradMty, gradMtz, divMt)
      COMPLEX, INTENT(IN) :: gradMtx(:,:,:,:), gradMty(:,:,:,:), gradMtz(:,:,:,:) !r,lm,n,x
      COMPLEX, INTENT(OUT) :: divMt(:,:,:)

      divMt(:,:,:)=gradMtx(:,:,:,1)+gradMty(:,:,:,2)+gradMtz(:,:,:,3)

   END SUBROUTINE divYlm

   SUBROUTINE rotYlm(gradMtx, gradMty, gradMtz, rotMt)
      COMPLEX, INTENT(IN) :: gradMtx(:,:,:,:), gradMty(:,:,:,:), gradMtz(:,:,:,:) !r,lm,n,x
      COMPLEX, INTENT(OUT) :: rotMt(:,:,:,:)

      rotMt(:,:,:,1)=gradMtz(:,:,:,2)-gradMty(:,:,:,3)
      rotMt(:,:,:,2)=gradMtx(:,:,:,3)-gradMtz(:,:,:,1)
      rotMt(:,:,:,3)=gradMty(:,:,:,1)-gradMtx(:,:,:,2)

   END SUBROUTINE rotYlm
END MODULE m_gradYlm


SUBROUTINE DETER(GMAX,pia,RBAS,kxmax,kymax,kzmax,lattic)
  !     **                                                              **
  !     **  CALCULATE RECIPROCAL LATTICE VECTORS FROM REAL SPACE        **
  !     **  LATTICE VECTORS OR VICE VERSA                               **
  !     **                                                              **
  IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  character*4 lattic
  DIMENSION RBAS(3,3),GBAS(3,3),pia(3)
  GBAS(1,1)=RBAS(2,2)*RBAS(3,3)-RBAS(3,2)*RBAS(2,3)
  GBAS(2,1)=RBAS(3,2)*RBAS(1,3)-RBAS(1,2)*RBAS(3,3)
  GBAS(3,1)=RBAS(1,2)*RBAS(2,3)-RBAS(2,2)*RBAS(1,3)
  GBAS(1,2)=RBAS(2,3)*RBAS(3,1)-RBAS(3,3)*RBAS(2,1)
  GBAS(2,2)=RBAS(3,3)*RBAS(1,1)-RBAS(1,3)*RBAS(3,1)
  GBAS(3,2)=RBAS(1,3)*RBAS(2,1)-RBAS(2,3)*RBAS(1,1)
  GBAS(1,3)=RBAS(2,1)*RBAS(3,2)-RBAS(3,1)*RBAS(2,2)
  GBAS(2,3)=RBAS(3,1)*RBAS(1,2)-RBAS(1,1)*RBAS(3,2)
  GBAS(3,3)=RBAS(1,1)*RBAS(2,2)-RBAS(2,1)*RBAS(1,2)
  DET=0.D0
  DO I=1,3
     DET=DET+GBAS(I,1)*RBAS(I,1)
  ENDDO
  kxmax0=DABS(GBAS(1,1)/DET*GMAX)
  kymax0=DABS(GBAS(1,2)/DET*GMAX)
  kzmax0=DABS(GBAS(1,3)/DET*GMAX)
  xtest=DABS(GBAS(2,1)/DET*GMAX)
  if (xtest.gt.kxmax0) kxmax0= xtest
  xtest=DABS(GBAS(3,1)/DET*GMAX)
  if (xtest.gt.kxmax0) kxmax0= xtest
  ytest=DABS(GBAS(2,2)/DET*GMAX)
  if (ytest.gt.kymax0) kymax0= ytest
  ytest=DABS(GBAS(3,2)/DET*GMAX)
  if (ytest.gt.kymax0) kymax0= ytest
  ztest=DABS(GBAS(2,3)/DET*GMAX)
  if (ztest.gt.kzmax0) kzmax0= ztest
  ztest=DABS(GBAS(3,3)/DET*GMAX)
  if (ztest.gt.kzmax0) kzmax0= ztest
  if(lattic(1:1).eq.'B') then
     kxmax1=gmax/sqrt(dble(pia(1)**2+pia(2)**2))
     kymax1=kxmax1
     kxmax2=gmax/sqrt(dble(pia(1)**2+pia(3)**2))
     kzmax1=kxmax2
     kymax2=gmax/sqrt(dble(pia(2)**2+pia(3)**2))
     kzmax2=kymax2
     kxmax=max(kxmax0,kxmax1,kxmax2)
     kymax=max(kymax0,kymax1,kymax2)
     kzmax=max(kzmax0,kzmax1,kzmax2)
     !          write(*,*) kxmax,kymax,kzmax,kxmax0,kymax0,kzmax0 &
     !         ,kxmax1,kymax1,kzmax1,kxmax2,kymax2,kzmax2
  else if(lattic(1:1).eq.'F') then
     kxmax1=gmax/sqrt(dble(pia(1)**2+pia(2)**2+pia(3)**2))
     kymax1=kxmax1
     kzmax1=kxmax1
     kxmax=max(kxmax0,kxmax1)
     kymax=max(kymax0,kymax1)
     kzmax=max(kzmax0,kzmax1)
     !          write(*,*) kxmax,kymax,kzmax,kxmax0,kymax0,kzmax0 &
     !         ,kxmax1,kymax1,kzmax1
  else if(lattic(1:3).eq.'CXY') then
     kxmax1=gmax/sqrt(dble(pia(1)**2+pia(2)**2))
     kymax1=kxmax1
     kzmax1=1
     kxmax=max(kxmax0,kxmax1)
     kymax=max(kymax0,kymax1)
     kzmax=max(kzmax0,kzmax1)
     !          write(*,*) kxmax,kymax,kzmax,kxmax0,kymax0,kzmax0 &
     !         ,kxmax1,kymax1,kzmax1
  else if(lattic(1:3).eq.'CXZ') then
     kxmax1=gmax/sqrt(dble(pia(1)**2+pia(3)**2))
     kzmax1=kxmax1
     kymax1=1
     kxmax=max(kxmax0,kxmax1)
     kymax=max(kymax0,kymax1)
     kzmax=max(kzmax0,kzmax1)
     !          write(*,*) kxmax,kymax,kzmax,kxmax0,kymax0,kzmax0 &
     !         ,kxmax1,kymax1,kzmax1
  else if(lattic(1:3).eq.'CYZ') then
     kzmax1=gmax/sqrt(dble(pia(2)**2+pia(3)**2))
     kymax1=kzmax1
     kxmax1=1
     kxmax=max(kxmax0,kxmax1)
     kymax=max(kymax0,kymax1)
     kzmax=max(kzmax0,kzmax1)
     !          write(6,*) kxmax,kymax,kzmax,kxmax0,kymax0,kzmax0 &
     !         ,kxmax1,kymax1,kzmax1
  else
     kxmax=max(kxmax0,1)
     kymax=max(kymax0,1)
     kzmax=max(kzmax0,1)
  endif
  RETURN
END SUBROUTINE DETER


      SUBROUTINE AXPXB(A,U,M,NA,NU,B,V,N,NB,NV,C,NC,EPSA,
     1EPSB,FAIL)
C
C   PURPOSE:
C      Solve the real matrix equation AX + XB = C, where A, B, and C
C      are constant matrices of order m x n, n x n, and m x n.  The ma-
C      trices are transformed into real lower and upper Schur form, and
C      the transformed system is solved by back substitution.  The op-
C      tion is provided to input the Schur forms directly and bypass
C      the Schur decomposition.
C
C   REFERENCES:
C      Bartels, R.H.; and Stewart, G.W.: Algorithm 432 - Solution of
C        the Matrix Equation AX + XB = C.  Commun. ACM, vol. 15, no. 9,
C        Sept. 1972, p. 820-826.
C
C   Subroutines employed by AXPXB: BCKMLT, HSHLDR, SCHUR, SHRSLV
C   Subroutines employing AXPXB: BARSTW
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8
     1A(NA,1),U(NU,1),B(NB,1),V(NV,1),C(NC,1),EPSA,EPSB,TEMP
      INTEGER
     1M,NA,NU,N,NB,NV,NC,FAIL,M1,MM1,N1,NM1,I,J,K
      M1 = M+1
      MM1 = M-1
      N1 = N+1
      NM1 = N-1
C
C IF REQUIRED, REDUCE A TO UPPER REAL SCHUR FORM.
C
      IF(EPSA .LT. 0.) GO TO 35
      DO 10 I=1,M
        DO 10 J=I,M
          TEMP = A(I,J)
          A(I,J) = A(J,I)
          A(J,I) = TEMP
   10 CONTINUE
      CALL HSHLDR(A,M,NA)
      CALL BCKMLT(A,U,M,NA,NU)
      IF(MM1 .EQ. 0) GO TO 25
      DO 20 I=1,MM1
        A(I+1,I) = A(I,M1)
   20 CONTINUE
      CALL SCHUR(A,U,M,NA,NU,EPSA,FAIL)
      IF(FAIL .NE. 0) RETURN
   25 DO 30 I=1,M
        DO 30 J=I,M
          TEMP = A(I,J)
          A(I,J) = A(J,I)
          A(J,I) = TEMP
   30 CONTINUE
C
C IF REQUIRED, REDUCE B TO UPPER REAL SCHUR FORM.
C
   35 IF(EPSB .LT. 0.) GO TO 45
      CALL HSHLDR(B,N,NB)
      CALL BCKMLT(B,V,N,NB,NV)
      IF(NM1 .EQ. 0) GO TO 45
      DO 40 I=1,NM1
        B(I+1,I) = B(I,N1)
   40 CONTINUE
      CALL SCHUR(B,V,N,NB,NV,EPSB,FAIL)
      FAIL = -FAIL
      IF(FAIL .NE. 0) RETURN
C
C TRANSFORM C.
C
   45 DO 60 J=1,N
        DO 50 I=1,M
          A(I,M1) = 0.
          DO 50 K=1,M
            A(I,M1) = A(I,M1) + U(K,I)*C(K,J)
   50 CONTINUE
      DO 60 I=1,M
        C(I,J) = A(I,M1)
   60 CONTINUE
      DO 80 I=1,M
        DO 70 J=1,N
          B(N1,J) = 0.
          DO 70 K=1,N
            B(N1,J) = B(N1,J) + C(I,K)*V(K,J)
   70 CONTINUE
      DO 80 J=1,N
        C(I,J) = B(N1,J)
   80 CONTINUE
C
C SOLVE THE TRANSFORMED SYSTEM.
C
      CALL SHRSLV(A,B,C,M,N,NA,NB,NC)
C
C TRANSFORM C BACK TO THE SOLUTION.
C
      DO 100 J=1,N
        DO 90 I=1,M
          A(I,M1) = 0.
          DO 90 K=1,M
            A(I,M1) = A(I,M1) + U(I,K)*C(K,J)
   90 CONTINUE
      DO 100 I=1,M
        C(I,J) = A(I,M1)
  100 CONTINUE
      DO 120 I=1,M
        DO 110 J=1,N
          B(N1,J) = 0.
          DO 110 K=1,N
            B(N1,J) = B(N1,J) + C(I,K)*V(J,K)
  110    CONTINUE
         DO 120 J=1,N
           C(I,J) = B(N1,J)
  120  CONTINUE
       RETURN
       END


program main
    use plantFEM
    implicit none

    real(real64) :: re64=100.0d0
    real(real64) :: vec(100)=1.0d0
    real(real64) :: vec3(3)=1.0d0
    real(real64) :: tensor(3,3)=0.0d0

    print *, "100 radian = ", degrees(re64),"degrees"
    print *, "100 degrees= ", radian(re64),"radian"

    print *, "real64 => string: ", str(re64)

    print *, "norm of vec(100) : ", norm(vec)

    tensor(:,:) = tensor_product(vec3,vec3)

    print *, tensor(1,:)
    print *, tensor(2,:)
    print *, tensor(3,:)

    tensor(:,:)=0.0d0

    tensor(1,1)=1.0d0
    tensor(2,2)=1.0d0
    tensor(3,3)=1.0d0

    print *, "det(tensor) : ", det_mat(tensor,size(tensor,1) )

    print *, "...etc."

end program main


program unreal
  real, external :: f

  print *,f(1,1,0.5)
  print *,f(2,2,0.5)
  print *,f(3,3,0.5)
  print *,f(4,4,0.5)
  print *,f(5,5,0.5)
  print *,f(10,2,0.70)
  print *,1-f(2,10,0.30)
  print *,f(10,10,0.70)

end program unreal

recursive real function f(i,j,p) result(w)
  integer :: i,j
  real :: p

  if (i==0) then
     w = 0.0
  else if (j==0) then
     w = 1.0
  else
     w = p*f(i-1,j,p)+(1-p)*f(i,j-1,p)
  end if

end function f


! -*-f90-*-
!### file:  cubspl.rat
      subroutine cubspl ( tau, c, n, ibcbeg, ibcend )
!     ************************  input  ***************************
!     n = number of data points. assumed to be .ge. 2.
!     (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the
!        data points. tau is assumed to be strictly increasing.
!     ibcbeg, ibcend = boundary condition indicators, and
!     c(2,1), c(2,n) = boundary condition information. specifically,
!        ibcbeg = 0  means no boundary condition at tau(1) is given.
!           in this case, the not-a-knot condition is used, i.e. the
!           jump in the third derivative across tau(2) is forced to
!           zero, thus the first and the second cubic polynomial pieces
!           are made to coincide.)
!        ibcbeg = 1  means that the slope at tau(1) is made to equal
!           c(2,1), supplied by input.
!        ibcbeg = 2  means that the second derivative at tau(1) is
!           made to equal c(2,1), supplied by input.
!        ibcend = 0, 1, or 2 has analogous meaning concerning the
!           boundary condition at tau(n), with the additional infor-
!           mation taken from c(2,n).
!     ***********************  output  **************************
!     c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients
!        of the cubic interpolating spline with interior knots (or
!        joints) tau(2), ..., tau(n-1). precisely, in the interval
!        interval (tau(i), tau(i+1)), the spline f is given by
!           f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
!        where h = x - tau(i). the function program *ppvalu* may be
!        used to evaluate f or its derivatives from tau,c, l = n-1,
!        and k=4.
      USE stel_kinds, ONLY: rprec
      integer :: ibcbeg,ibcend,n,   i,j,l,m
      real(rprec) :: c(4,n), tau(n), divdf1, divdf3, dtau, g
!****** a tridiagonal linear system for the unknown slopes s(i) of
!  f  at tau(i), i=1,...,n, is generated and then solved by gauss elim-
!  ination, with s(i) ending up in c(2,i), all i.
!     c(3,.) and c(4,.) are used initially for temporary storage.
      l = n-1
      !ompute first differences of tau sequence and store in c(3,.). also,
      !ompute first divided difference of data and store in c(4,.).
      do 10 m=2,n
         c(3,m) = tau(m) - tau(m-1)
   10    c(4,m) = (c(1,m) - c(1,m-1))/c(3,m)
   !onstruct first equation from the boundary condition, of the form
   !             c(4,1)*s(1) + c(3,1)*s(2) = c(2,1)
      if (ibcbeg-1)                     11,15,16
   11 if (n .gt. 2)                     go to 12
   !     no condition at left end and n = 2.
      c(4,1) = 1.
      c(3,1) = 1.
      c(2,1) = 2.*c(4,2)
                                        go to 25
                                        !     not-a-knot condition at left end and n .gt. 2.
   12 c(4,1) = c(3,3)
      c(3,1) = c(3,2) + c(3,3)
      c(2,1) =((c(3,2)+2.*c(3,1))*c(4,2)*c(3,3)+c(3,2)**2*c(4,3))/c(3,1)
                                        go to 19
                                        !     slope prescribed at left end.
   15 c(4,1) = 1.
      c(3,1) = 0.
                                        go to 18
                                        !     second derivative prescribed at left end.
   16 c(4,1) = 2.
      c(3,1) = 1.
      c(2,1) = 3.*c(4,2) - c(3,2)/2.*c(2,1)
   18 if(n .eq. 2)                      go to 25
   !  if there are interior knots, generate the corresp. equations and car-
   !  ry out the forward pass of gauss elimination, after which the m-th
   !  equation reads    c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m).
   19 do 20 m=2,l
         g = -c(3,m+1)/c(4,m-1)
         c(2,m) = g*c(2,m-1) + 3.*(c(3,m)*c(4,m+1)+c(3,m+1)*c(4,m))
   20    c(4,m) = g*c(3,m-1) + 2.*(c(3,m) + c(3,m+1))
   !onstruct last equation from the second boundary condition, of the form
   !           (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n)
   !     if slope is prescribed at right end, one can go directly to back-
   !     substitution, since c array happens to be set up just right for it
   !     at this point.
      if (ibcend-1)                     21,30,24
   21 if (n .eq. 3 .and. ibcbeg .eq. 0) go to 22
   !     not-a-knot and n .ge. 3, and either n.gt.3 or  also not-a-knot at
   !     left end point.
      g = c(3,n-1) + c(3,n)
      c(2,n) = ((c(3,n)+2.*g)*c(4,n)*c(3,n-1) +
     1          c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g
      g = -g/c(4,n-1)
      c(4,n) = c(3,n-1)
                                        go to 29
                                        !     either (n=3 and not-a-knot also at left) or (n=2 and not not-a-
                                        !     knot at left end point).
   22 c(2,n) = 2.*c(4,n)
      c(4,n) = 1.
                                        go to 28
                                        !     second derivative prescribed at right endpoint.
   24 c(2,n) = 3.*c(4,n) + c(3,n)/2.*c(2,n)
      c(4,n) = 2.
                                        go to 28
   25 if (ibcend-1)                     26,30,24
   26 if (ibcbeg .gt. 0)                go to 22
   !     not-a-knot at right endpoint and at left endpoint and n = 2.
      c(2,n) = c(4,n)
                                        go to 30
   28 g = -1./c(4,n-1)
   !omplete forward pass of gauss elimination.
   29 c(4,n) = g*c(3,n-1) + c(4,n)
      c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n)
      !arry out back substitution
   30 do 40 j=l,1,-1
   40    c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j)
   !****** generate cubic coefficients in each interval, i.e., the deriv.s
   !  at its left endpoint, from value and slope at its endpoints.
      do 50 i=2,n
         dtau = c(3,i)
         divdf1 = (c(1,i) - c(1,i-1))/dtau
         divdf3 = c(2,i-1) + c(2,i) - 2.*divdf1
         c(3,i-1) = 2.*(divdf1 - c(2,i-1) - divdf3)/dtau
   50    c(4,i-1) = (divdf3/dtau)*(6./dtau)
                                        return
      end