!***********************************************************************
!* Interpolation Routines:
!*   INTERP_S - In-place interpolation
!*   INTERP_SN - Out-of-place interpolation
!*   INTERP_XY_S - X-Y interpolation
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!*
!* Notes:
!* . In-place: overwrites Y array, range, and step with interpolated data
!* . Out-of-place: writes Z array, range, and step with interpolated data
!***********************************************************************

      SUBROUTINE INTERP_S( Z, NFP_L, NLP_U, NFP, NLP, DX, DX_NEW, IOS )

!***********************************************************************
!* In-Place Interpolation of an Array to a New Step Value
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!*
!* Notes:
!* . This routine does not worry about aliasing, so the input signal
!*   should be filtered appropriately for the new step prior to
!*   interpolation
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NFP_L ! Data array lower index limit

      INTEGER NLP_U ! Data array upper index limit

      REAL Z(NFP_L:NLP_U) ! Data array -> Interpolated data

      INTEGER NFP ! Index of first data point

      INTEGER NLP ! Index of last data point

      DOUBLE PRECISION DX ! X-axis step (delta-x) of data (>0)

      DOUBLE PRECISION DX_NEW ! New X-axis step (delta-x) desired (>0)

      INTEGER IOS ! Status flag returned

      ! Do in-place interpolation
      CALL INTERP_SN( Z, NFP_L, NLP_U, NFP, NLP, DX, DX_NEW,
     & Z, NFP, NLP, DX, IOS )

      RETURN
      END

      SUBROUTINE INTERP_SN( Z, NFP_L, NLP_U, NFP, NLP, DX, DX_NEW,
     & Z_OUT, NFP_OUT, NLP_OUT, DX_OUT, IOS )

!***********************************************************************
!* Interpolation of an Array to a New Step Value
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!*
!* Notes:
!* . This routine does not worry about aliasing, so the input signal
!*   should be filtered appropriately for the new step prior to
!*   interpolation
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NFP_L ! Data array lower index limit

      INTEGER NLP_U ! Data array upper index limit

      REAL Z(NFP_L:NLP_U) ! Data array

      INTEGER NFP ! Index of first data point

      INTEGER NLP ! Index of last data point

      DOUBLE PRECISION DX ! X-axis step (delta-x) of data (>0)

      DOUBLE PRECISION DX_NEW ! New X-axis step (delta-x) desired (>0)

      REAL Z_OUT(NFP_L:NLP_U) ! Interpolated data array (can send Z)

      INTEGER NFP_OUT ! Index of first interpolated point (can send NFP)

      INTEGER NLP_OUT ! Index of last interpolated point (can send NLP)

      DOUBLE PRECISION DX_OUT ! Interpolated X-axis step (delta-x) (>0)

      INTEGER IOS ! Status flag returned

      ! Variables ______________________________________________________

      INTEGER NFP_NEW, NLP_NEW, ISUB, NSUB, N

      DOUBLE PRECISION STT, FTT

      ! Functions ______________________________________________________

      LOGICAL EQUAL_DP

      EXTERNAL EQUAL_DP

      ! Check for valid step values
      IF ( ( DX .LE. 0.D0 ) .OR. ( DX_NEW .LE. 0.D0 ) ) THEN
        IOS = 1
        RETURN
      END IF
      IOS = 0

      ! Check for subsampling
      NSUB = NINT( DX_NEW / DX )
      IF ( .NOT. EQUAL_DP( DX_NEW, NSUB * DX, 1.D-15 ) ) THEN ! Interp
        ISUB = 0
      ELSE ! Subsample
        ISUB = NSUB
      END IF

      ! Set first point index for output signals
      STT = NFP * DX
      NFP_NEW = NINT( STT / DX_NEW )
      IF ( ( NFP_NEW * DX_NEW .LT. STT ) .AND.
     & ( .NOT. EQUAL_DP( NFP_NEW * DX_NEW, STT, 2.D-7 ) ) ) THEN
        NFP_NEW = NFP_NEW + 1
      END IF
      IF ( NFP_NEW .LT. NFP_L ) THEN
        NFP_NEW = NFP_L
      END IF

      ! Set last point index for output signals
      FTT = NLP * DX
      NLP_NEW = NINT( FTT / DX_NEW )
      IF ( ( NLP_NEW * DX_NEW .GT. FTT ) .AND.
     & ( .NOT. EQUAL_DP( NLP_NEW * DX_NEW, FTT, 2.D-7 ) ) ) THEN
        NLP_NEW = NLP_NEW - 1
      END IF
      IF ( NLP_NEW .GT. NLP_U ) THEN
        NLP_NEW = NLP_U
      END IF

      ! Subsample or interpolate to new step
      IF ( ISUB .GT. 0 ) THEN ! Subsample

        DO N = MAX(0,NFP_NEW), NLP_NEW
          Z_OUT(N) = Z(N*ISUB)
        END DO
        DO N = MIN(-1,NLP_NEW), NFP_NEW, -1
          Z_OUT(N) = Z(N*ISUB)
        END DO

      ELSE ! Interpolate

        IF ( DX_NEW .GT. DX ) THEN ! Outward assign to avoid overwriting

          DO N = MAX(0,NFP_NEW), NLP_NEW
            CALL INTERP_VAL( Z, NFP_L, NLP_U, DX, DX_NEW,
     &         N, Z_OUT(N) )
          END DO
          DO N = MIN(-1,NLP_NEW), NFP_NEW, -1
            CALL INTERP_VAL( Z, NFP_L, NLP_U, DX, DX_NEW,
     &         N, Z_OUT(N) )
          END DO

        ELSE ! Inward assign to avoid overwriting

          DO N = NLP_NEW, MAX(0,NFP_NEW), -1
            CALL INTERP_VAL( Z, NFP_L, NLP_U, DX, DX_NEW,
     &         N, Z_OUT(N) )
          END DO
          DO N = NFP_NEW, MIN(-1,NLP_NEW)
            CALL INTERP_VAL( Z, NFP_L, NLP_U, DX, DX_NEW,
     &         N, Z_OUT(N) )
          END DO

        END IF

      END IF

      ! Set output array index range and x-axis step
      NFP_OUT = NFP_NEW
      NLP_OUT = NLP_NEW
      DX_OUT = DX_NEW

      RETURN
      END

      SUBROUTINE INTERP_VAL( Z, NFP_L, NLP_U, DX, DX_NEW, N, ZN )

!***********************************************************************
!* Sets a Single Interpolated Value
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!*
!* Notes:
!* . Assumes INTERP_VAL calls ordered to avoid overwriting
!* . Assumes N*DX_NEW falls within valid Z range
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NFP_L ! Data array lower index limit

      INTEGER NLP_U ! Data array upper index limit

      REAL Z(NFP_L:NLP_U) ! Data array

      DOUBLE PRECISION DX ! X-axis step (delta-x) of data (>0)

      DOUBLE PRECISION DX_NEW ! New X-axis step (delta-x) desired (>0)

      INTEGER N ! Interpolated data index

      REAL ZN ! Interpolated data value

      ! Variables ______________________________________________________

      INTEGER I

      DOUBLE PRECISION XN

      ! Functions ______________________________________________________

      LOGICAL EQUAL_DP

      EXTERNAL EQUAL_DP

      ! Set interpolated value
      XN = N * DX_NEW
      I = NINT( XN / DX ) ! Nearest index in input array
      IF ( .NOT. EQUAL_DP( I * DX, XN, 1.D-15 ) ) THEN ! Between points
        IF ( N .GT. 0 ) THEN
          I = INT( XN / DX ) ! Downward round for (+) value
        ELSE ! N < 0
          I = INT( XN / DX ) - 1 ! Downward round for (-) value
        END IF
        ZN = REAL( Z(I) + ( ( XN / DX ) - I ) * ( Z(I+1) - Z(I) ) )
      ELSE ! On a point
        ZN = Z(I)
      END IF

      RETURN
      END

      SUBROUTINE INTERP_XY_S( X, Y, NFP_L, NLP_U, NFP, NLP,
     & DX_NEW, Y_OUT, NFP_OUT, NLP_OUT, IOS )

!***********************************************************************
!* Interpolation of X-Y Signal to a Specified Even Step Value
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!*
!* Notes:
!* . This routine does not worry about aliasing, so the input signal
!*   should be filtered appropriately for the new step prior to
!*   interpolation
!* . X array not set to even step
!* . Returns the initial x-monotonic segment if y(x) is multi-valued
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NFP_L ! Data array lower index limit

      INTEGER NLP_U ! Data array upper index limit

      REAL X(NFP_L:NLP_U) ! X-axis data array

      REAL Y(NFP_L:NLP_U) ! Y-axis data array

      INTEGER NFP ! Index of first data point

      INTEGER NLP ! Index of last data point

      DOUBLE PRECISION DX_NEW ! New X-axis step (delta-x) desired (>0)

      REAL Y_OUT(NFP_L:NLP_U) ! Interpolated Y-axis data array

      INTEGER NFP_OUT ! Index of first interpolated data point

      INTEGER NLP_OUT ! Index of last interpolated data point

      INTEGER IOS ! Status flag returned

      ! Variables ______________________________________________________

      LOGICAL FIRST

      INTEGER I, K, INC, NA, NB

      DOUBLE PRECISION XM, XI, XD, XK, YM, YI, YD, FRAC

      ! Functions ______________________________________________________

      LOGICAL EQUAL_DP

      EXTERNAL EQUAL_DP

      ! Check for valid step value
      IF ( ( DX_NEW .LE. 0.D0 ) .OR. ( NFP .GE. NLP ) ) THEN
        IOS = 1
        RETURN
      END IF
      IOS = 0

      ! Set x-axis direction
      IF ( X(NFP) .LE. X(NFP+1) ) THEN ! Increasing
        INC = 1
      ELSE ! Decreasing
        INC = -1
      END IF

      ! Interpolate to even step
      I = NFP
      XI = X(I)
      YI = Y(I)
      FIRST = .TRUE.
      DO WHILE ( ( I .LT. NLP ) .AND. ( X(I+1) * INC .GE. XI * INC ) )
        I = I + 1
        XM = XI
        XI = X(I)
        XD = XI - XM
        NA = MIN( MAX( INT( XM / DX_NEW - INC ), NFP_L ), NLP_U )
        NB = MIN( MAX( INT( XI / DX_NEW + INC ), NFP_L ), NLP_U )
        YM = YI
        YI = Y(I)
        YD = YI - YM
        DO K = NA, NB, INC
          XK = K * DX_NEW
          IF ( ( ( XK .GE. MIN( XM, XI ) ) .AND.
     &       ( XK .LE. MAX( XM, XI ) ) ) .OR.
     &       ( EQUAL_DP( XK, XM, 2.D-7 ) ) .OR.
     &       ( EQUAL_DP( XK, XI, 2.D-7 ) ) ) THEN ! In range
            IF ( XD .NE. 0.D0 ) THEN
              FRAC = ( XK - XM ) / XD
              Y_OUT(K) = REAL( YM + FRAC * YD )
            ELSE
              Y_OUT(K) = REAL( YM )
            END IF
            IF ( FIRST ) THEN
              NFP_OUT = K
              NLP_OUT = K
              FIRST = .FALSE.
            ELSE
              NFP_OUT = MIN( NFP_OUT, K )
              NLP_OUT = MAX( NLP_OUT, K )
            END IF
          END IF
        END DO
      END DO

      IF ( FIRST ) IOS = 2 ! No output

      RETURN
      END


      SUBROUTINE POLYMASK(N,X,Y,M,POLY,MASK)

Cf2py intent(in) N
Cf2py intent(in) X
Cf2py depend(N) X
Cf2py intent(in) Y
Cf2py depend(N) Y
Cf2py intent(in) M
Cf2py intent(in) POLY
Cf2py depend(M) POLY
Cf2py intent(in,out) MASK

      IMPLICIT NONE
      INTEGER*4    N,M
      REAL*4       X(0:N-1),Y(0:N-1)
      REAL*8       POLY(0:M-1,0:1)
      LOGICAL*1    MASK(0:1024*1024-1)

      INTEGER*4    I,K
      REAL*4       P1X,P1Y,P2X,P2Y,XINTERS

      DO K=0,N-1
        MASK(K) = .FALSE.
        DO I=0,M-1
          P2X = POLY(I,0)
          P2Y = POLY(I,1)
          IF (Y(K) .GT. MIN(P1Y,P2Y)) THEN
            IF (Y(K) .LE. MAX(P1Y,P2Y)) THEN
              IF (X(K) .LE. MAX(P1X,P2X)) THEN
                IF (P1Y .NE.P2Y) THEN
                  XINTERS = (Y(K)-P1Y)*(P2X-P1X)/(P2Y-P1Y)+P1X
                END IF
                IF ( (P1X .EQ. P2X) .OR. (X(K) .LE. XINTERS) ) THEN
                  MASK(K) = .NOT.MASK(K)
                END IF
              END IF
            END IF
          END IF
          P1X = P2X
          P1Y = P2Y
        END DO
      END DO

      RETURN
      END


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Sat Jun  1 14:48:41
!
!a=./f && make $a && OMP_NUM_THREADS=2 $a < unixdict.txt # some of the compilation options and redirection from unixdict.txt are vestigial.
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none f.f08 -o f
!                 123  123
!               12345  234
!             1234567  345
!           987654321  654
!               10001  000
!              -10001  000
!                -123  123
!                -100  100
!                 100  100
!              -12345  234
!                   1  Too short
!                   2  Too short
!                  -1  Too short
!                 -10  Too short
!                2002  Digit count too even
!               -2002  Digit count too even
!                   0  Too short
!
!Compilation finished at Sat Jun  1 14:48:41

program MiddleMuddle
  integer, dimension(17) :: itest, idigits
  integer :: i, n
  data itest/123,12345,1234567,987654321,10001,-10001,-123,-100,100,-12345,1,2,-1,-10,2002,-2002,0/
  do i = 1, size(itest)
    call antibase(10, abs(itest(i)), idigits, n)
    write(6,'(i20,2x,a20)') itest(i), classifym3(idigits, n)
    if (0 .eq. itest(i)) exit
  end do

contains

  logical function even(n)
    integer, intent(in) :: n
    even = 0 .eq. iand(n,1)
  end function even

  function classifym3(iarray, n) result(s)
    integer, dimension(:), intent(in) :: iarray
    integer, intent(in) :: n
    character(len=20) :: s
    integer :: i,m
    if (n < 3) then
      s = 'Too short'
    else if (even(n)) then
      s = 'Digit count too even'
    else
      m = (n+1)/2
      write(s,'(3i1)')(iarray(i), i=m+1,m-1,-1)
    end if
  end function classifym3

  subroutine antibase(base, m, digits, n) ! digits ordered by increasing significance
    integer, intent(in) :: base, m
    integer, intent(out) :: n  ! the number of digits
    integer, dimension(:), intent(out) :: digits
    integer :: em
    em = m
    do n=1, size(digits)
      digits(n) = mod(em, base)
      em = em / base
      if (0 .eq. em) return
    end do
    stop 'antibase ran out of space to store result'
  end subroutine antibase

end program MiddleMuddle


module time_smooth_mod
  use kind_params_mod
  use grid_mod
  use field_mod
  use kernel_mod
  use argument_mod
  IMPLICIT none

  PRIVATE

  PUBLIC time_smooth_init, invoke_time_smooth
  PUBLIC time_smooth, time_smooth_code

  !> Parameter for time smoothing
  REAL(go_wp), save :: alpha

  !> The time smoothing operates in time rather than space
  !! and therefore takes three fields defined on any one
  !! of the four grid point types (T, U, V or Q).
  !! Presumably FE should be FD for us and maybe CELLS
  !! should be COLUMNS?
  TYPE, EXTENDS(kernel_type) :: time_smooth
     TYPE(go_arg), DIMENSION(3) :: meta_args = &
          (/ go_arg(GO_READ, GO_EVERY, GO_POINTWISE),     &
             go_arg(GO_READ, GO_EVERY, GO_POINTWISE),     &
             go_arg(GO_READWRITE , GO_EVERY, GO_POINTWISE)      &
           /)

     !> This kernel writes only to internal points of the
     !! simulation domain.
     INTEGER :: ITERATES_OVER = GO_INTERNAL_PTS

     !> Although the staggering of variables used in an Arakawa
     !! C grid is well defined, the way in which they are indexed is
     !! an implementation choice. This can be thought of as choosing
     !! which grid-point types have the same (i,j) index as a T
     !! point. This kernel is independent of this choice (because it
     !! acts in time rather than space).
     integer :: index_offset = GO_OFFSET_ANY

  CONTAINS
    procedure, nopass :: code => time_smooth_code
  END type time_smooth

CONTAINS

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

  !> Initialise the time-smoothing module. Sets parameter
  !! alpha that is used in the time-smooth kernel.
  SUBROUTINE time_smooth_init(alpha_tmp)
    IMPLICIT none
    REAL(go_wp), INTENT(in) :: alpha_tmp

    alpha = alpha_tmp

  END SUBROUTINE time_smooth_init

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

  !> Manual implementation of code to invoke the time-smoothing
  !! kernel
  subroutine invoke_time_smooth(field, field_new, field_old)
    implicit none
    type(r2d_field), intent(in)    :: field
    type(r2d_field), intent(in)    :: field_new
    type(r2d_field), intent(inout) :: field_old
    ! Locals
    integer :: i, j
    integer :: idim1, idim2

    ! Here we will query what should be field objects to get at
    ! raw data.
    idim1 = SIZE(field%data, 1)
    idim2 = SIZE(field%data, 2)

    ! Loop over 'columns'
    DO J=1,idim2
      DO I=1,idim1
         CALL time_smooth_code(i, j, &
                               field%data, field_new%data, field_old%data)
      END DO
    END DO

  end subroutine invoke_time_smooth

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

  !> Kernel to smooth supplied field in time
  SUBROUTINE time_smooth_code(i, j, field, field_new, field_old)
    IMPLICIT none
    INTEGER,  INTENT(in)                    :: i, j
    REAL(go_wp), INTENT(in),    DIMENSION(:,:) :: field
    REAL(go_wp), INTENT(in),    DIMENSION(:,:) :: field_new
    REAL(go_wp), INTENT(inout), DIMENSION(:,:) :: field_old

    field_old(i,j) = field(i,j) + &
         alpha*(field_new(i,j) - 2.0d0*field(i,j) + field_old(i,j))

  END SUBROUTINE time_smooth_code

END MODULE time_smooth_mod


c compile it using: f95 -Wall -O3 test.f expm.o -lm -llapack -lblas -o test_expm
      program hello
         COMPLEX*16, allocatable::M(:,:)
         INTEGER DIM

         DIM = 3

         allocate(M(1:DIM,1:DIM))

         M(1,1) = 21
         M(1,2) = 17
         M(1,3) = 6

         M(2,1) = -5
         M(2,2) = -1
         M(2,3) = -6

         M(3,1) = 4
         M(3,2) = 4
         M(3,3) = 16

         call expm(M,DIM)
      end program hello


!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine magfie_vmec(x,bmod,sqrtg,bder,hcovar,hctrvr,hcurl)
!
! Computes magnetic field module in units of the magnetic code  - bmod,
! square root of determinant of the metric tensor               - sqrtg,
! derivatives of the logarythm of the magnetic field module
! over coordinates                                              - bder,
! covariant componets of the unit vector of the magnetic
! field direction                                               - hcovar,
! contravariant components of this vector                       - hctrvr,
! contravariant component of the curl of this vector            - hcurl
! Order of coordinates is the following: x(1)=s (normalized toroidal flux),
! x(2)=theta (VMEC poloidal angle), x(3)=varphi (geometrical toroidal angle).
!
!  Input parameters:
!            formal:  x(3)             - array of VMEC coordinates
!  Output parameters:
!            formal:  bmod
!                     sqrtg
!                     bder(3)          - derivatives of $\log(B)$
!                     hcovar(3)        - covariant components of unit vector $\bh$ along $\bB$
!                     hctrvr(3)        - contra-variant components of unit vector $\bh$ along $\bB$
!                     hcurl(3)         - contra-variant components of curl of $\bh$
!
!  Called routines: vmec_field
!
  implicit none
!
  double precision, parameter :: twopi=2.d0*3.14159265358979d0, hs=1.d-3, ht=hs*twopi, hp=ht/5.d0
!
  double precision :: bmod,sqrtg
  double precision :: s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                      sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                      Bcovar_r,Bcovar_vartheta,Bcovar_varphi
  double precision :: cjac,bcov_s_vmec,bcov_t_vmec,bcov_p_vmec
  double precision :: dhs_dt,dhs_dp,dht_ds,dht_dp,dhp_ds,dhp_dt
  double precision, dimension(3) :: x,bder,hcovar,hctrvr,hcurl
!
! Begin derivatives over s
!
  theta=x(2)
  varphi=x(3)
  s=x(1)+hs
!
  call vmec_field(s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                  sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                  Bcovar_r,Bcovar_vartheta,Bcovar_varphi)
!
  bmod=sqrt(Bctrvr_vartheta*Bcovar_vartheta+Bctrvr_varphi*Bcovar_varphi)
  bcov_s_vmec=Bcovar_r+dl_ds*Bcovar_vartheta
  bcov_t_vmec=(1.d0+dl_dt)*Bcovar_vartheta
  bcov_p_vmec=Bcovar_varphi+dl_dp*Bcovar_vartheta
  bder(1)=bmod
  dht_ds=bcov_t_vmec/bmod
  dhp_ds=bcov_p_vmec/bmod
!
  s=x(1)-hs
!
  call vmec_field(s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                  sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                  Bcovar_r,Bcovar_vartheta,Bcovar_varphi)
!
  bmod=sqrt(Bctrvr_vartheta*Bcovar_vartheta+Bctrvr_varphi*Bcovar_varphi)
  bcov_s_vmec=Bcovar_r+dl_ds*Bcovar_vartheta
  bcov_t_vmec=(1.d0+dl_dt)*Bcovar_vartheta
  bcov_p_vmec=Bcovar_varphi+dl_dp*Bcovar_vartheta
  bder(1)=(bder(1)-bmod)/(2.d0*hs)
  dht_ds=(dht_ds-bcov_t_vmec/bmod)/(2.d0*hs)
  dhp_ds=(dhp_ds-bcov_p_vmec/bmod)/(2.d0*hs)
!
! End derivatives over s
!
!-------------------------
!
! Begin derivatives over theta
!
  s=x(1)
  theta=x(2)+ht
!
  call vmec_field(s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                  sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                  Bcovar_r,Bcovar_vartheta,Bcovar_varphi)
!
  bmod=sqrt(Bctrvr_vartheta*Bcovar_vartheta+Bctrvr_varphi*Bcovar_varphi)
  bcov_s_vmec=Bcovar_r+dl_ds*Bcovar_vartheta
  bcov_t_vmec=(1.d0+dl_dt)*Bcovar_vartheta
  bcov_p_vmec=Bcovar_varphi+dl_dp*Bcovar_vartheta
  bder(2)=bmod
  dhs_dt=bcov_s_vmec/bmod
  dhp_dt=bcov_p_vmec/bmod
!
  theta=x(2)-ht
!
  call vmec_field(s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                  sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                  Bcovar_r,Bcovar_vartheta,Bcovar_varphi)
!
  bmod=sqrt(Bctrvr_vartheta*Bcovar_vartheta+Bctrvr_varphi*Bcovar_varphi)
  bcov_s_vmec=Bcovar_r+dl_ds*Bcovar_vartheta
  bcov_t_vmec=(1.d0+dl_dt)*Bcovar_vartheta
  bcov_p_vmec=Bcovar_varphi+dl_dp*Bcovar_vartheta
  bder(2)=(bder(2)-bmod)/(2.d0*ht)
  dhs_dt=(dhs_dt-bcov_s_vmec/bmod)/(2.d0*ht)
  dhp_dt=(dhp_dt-bcov_p_vmec/bmod)/(2.d0*ht)
!
! End derivatives over theta
!
!-------------------------
!
! Begin derivatives over varphi
!
  theta=x(2)
  varphi=x(3)+hp
!
  call vmec_field(s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                  sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                  Bcovar_r,Bcovar_vartheta,Bcovar_varphi)
!
  bmod=sqrt(Bctrvr_vartheta*Bcovar_vartheta+Bctrvr_varphi*Bcovar_varphi)
  bcov_s_vmec=Bcovar_r+dl_ds*Bcovar_vartheta
  bcov_t_vmec=(1.d0+dl_dt)*Bcovar_vartheta
  bcov_p_vmec=Bcovar_varphi+dl_dp*Bcovar_vartheta
  bder(3)=bmod
  dhs_dp=bcov_s_vmec/bmod
  dht_dp=bcov_t_vmec/bmod
!
  varphi=x(3)-hp
!
  call vmec_field(s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                  sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                  Bcovar_r,Bcovar_vartheta,Bcovar_varphi)
!
  bmod=sqrt(Bctrvr_vartheta*Bcovar_vartheta+Bctrvr_varphi*Bcovar_varphi)
  bcov_s_vmec=Bcovar_r+dl_ds*Bcovar_vartheta
  bcov_t_vmec=(1.d0+dl_dt)*Bcovar_vartheta
  bcov_p_vmec=Bcovar_varphi+dl_dp*Bcovar_vartheta
  bder(3)=(bder(3)-bmod)/(2.d0*hp)
  dhs_dp=(dhs_dp-bcov_s_vmec/bmod)/(2.d0*hp)
  dht_dp=(dht_dp-bcov_t_vmec/bmod)/(2.d0*hp)
!
! End derivatives over varphi
!
!-------------------------
!
  varphi=x(3)
!
  call vmec_field(s,theta,varphi,A_theta,A_phi,dA_theta_ds,dA_phi_ds,aiota,     &
                  sqg,alam,dl_ds,dl_dt,dl_dp,Bctrvr_vartheta,Bctrvr_varphi,     &
                  Bcovar_r,Bcovar_vartheta,Bcovar_varphi)
!
  bmod=sqrt(Bctrvr_vartheta*Bcovar_vartheta+Bctrvr_varphi*Bcovar_varphi)
  cjac=1.d0+dl_dt
  sqrtg=sqg*cjac
  bder=bder/bmod
  bcov_s_vmec=Bcovar_r+dl_ds*Bcovar_vartheta
  bcov_t_vmec=(1.d0+dl_dt)*Bcovar_vartheta
  bcov_p_vmec=Bcovar_varphi+dl_dp*Bcovar_vartheta
  hcovar(1)=bcov_s_vmec/bmod
  hcovar(2)=bcov_t_vmec/bmod
  hcovar(3)=bcov_p_vmec/bmod
  hctrvr(1)=0.d0
  hctrvr(2)=(Bctrvr_vartheta-dl_dp*Bctrvr_varphi)/(cjac*bmod)
  hctrvr(3)=Bctrvr_varphi/bmod
  hcurl(1)=(dhp_dt-dht_dp)/sqrtg
  hcurl(2)=(dhs_dp-dhp_ds)/sqrtg
  hcurl(3)=(dht_ds-dhs_dt)/sqrtg
!
  end subroutine magfie_vmec
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine magfie_can(x,bmod,sqrtg,bder,hcovar,hctrvr,hcurl)
!
!
! Computes magnetic field module in units of the magnetic code  - bmod,
! square root of determinant of the metric tensor               - sqrtg,
! derivatives of the logarythm of the magnetic field module
! over coordinates                                              - bder,
! covariant componets of the unit vector of the magnetic
! field direction                                               - hcovar,
! contravariant components of this vector                       - hctrvr,
! contravariant component of the curl of this vector            - hcurl
! Order of coordinates is the following: x(1)=s (normalized toroidal flux),
! x(2)=vartheta_c (canonical poloidal angle), x(3)=varphi_c (canonical toroidal angle).
!
!  Input parameters:
!            formal:  x(3)             - array of canonical coordinates
!  Output parameters:
!            formal:  bmod
!                     sqrtg
!                     bder(3)          - derivatives of $\log(B)$
!                     hcovar(3)        - covariant components of unit vector $\bh$ along $\bB$
!                     hctrvr(3)        - contra-variant components of unit vector $\bh$ along $\bB$
!                     hcurl(3)         - contra-variant components of curl of $\bh$
!
!  Called routines: canonical_field
!
  implicit none
!
  logical :: fullset
  integer :: mode_secders
  double precision :: bmod,sqrtg
  double precision :: r,vartheta_c,varphi_c,                                           &
                      A_phi,A_theta,dA_phi_dr,dA_theta_dr,d2A_phi_dr2,d3A_phi_dr3,     &
                      sqg_c,dsqg_c_dr,dsqg_c_dt,dsqg_c_dp,                             &
                      B_vartheta_c,dB_vartheta_c_dr,dB_vartheta_c_dt,dB_vartheta_c_dp, &
                      B_varphi_c,dB_varphi_c_dr,dB_varphi_c_dt,dB_varphi_c_dp,G_c,     &
                      d2sqg_rr,d2sqg_rt,d2sqg_rp,d2sqg_tt,d2sqg_tp,d2sqg_pp,           &
                      d2bth_rr,d2bth_rt,d2bth_rp,d2bth_tt,d2bth_tp,d2bth_pp,           &
                      d2bph_rr,d2bph_rt,d2bph_rp,d2bph_tt,d2bph_tp,d2bph_pp
  double precision :: Bctr_vartheta,Bctr_varphi,bmod2
  double precision, dimension(3) :: x,bder,hcovar,hctrvr,hcurl
!
  r=x(1)
  vartheta_c=x(2)
  varphi_c=x(3)
!
  fullset=.false.
  mode_secders=0
!
  call splint_can_coord(fullset,mode_secders,r,vartheta_c,varphi_c,                      &
                        A_theta,A_phi,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3,     &
                        sqg_c,dsqg_c_dr,dsqg_c_dt,dsqg_c_dp,                             &
                        B_vartheta_c,dB_vartheta_c_dr,dB_vartheta_c_dt,dB_vartheta_c_dp, &
                        B_varphi_c,dB_varphi_c_dr,dB_varphi_c_dt,dB_varphi_c_dp,         &
                        d2sqg_rr,d2sqg_rt,d2sqg_rp,d2sqg_tt,d2sqg_tp,d2sqg_pp,           &
                        d2bth_rr,d2bth_rt,d2bth_rp,d2bth_tt,d2bth_tp,d2bth_pp,           &
                        d2bph_rr,d2bph_rt,d2bph_rp,d2bph_tt,d2bph_tp,d2bph_pp,G_c)
!
  sqrtg=sqg_c
!
  Bctr_vartheta=-dA_phi_dr/sqg_c
  Bctr_varphi=dA_theta_dr/sqg_c
!
  bmod2=Bctr_vartheta*B_vartheta_c+Bctr_varphi*B_varphi_c
  bmod=sqrt(bmod2)
!
  bder(1)=0.5d0*((dA_theta_dr*dB_varphi_c_dr-dA_phi_dr*dB_vartheta_c_dr-d2A_phi_dr2*B_vartheta_c) &
         /bmod2-dsqg_c_dr)/sqg_c
  bder(2)=0.5d0*((dA_theta_dr*dB_varphi_c_dt-dA_phi_dr*dB_vartheta_c_dt)/bmod2-dsqg_c_dt)/sqg_c
  bder(3)=0.5d0*((dA_theta_dr*dB_varphi_c_dp-dA_phi_dr*dB_vartheta_c_dp)/bmod2-dsqg_c_dp)/sqg_c
!
  hcovar(1)=0.d0
  hcovar(2)=B_vartheta_c/bmod
  hcovar(3)=B_varphi_c/bmod
!
  hctrvr(1)=0.d0
  hctrvr(2)=Bctr_vartheta/bmod
  hctrvr(3)=Bctr_varphi/bmod
!
  hcurl(1)=((dB_varphi_c_dt-dB_vartheta_c_dp)/bmod-bder(2)*hcovar(3)+bder(3)*hcovar(2))/sqg_c
  hcurl(2)=(-dB_varphi_c_dr/bmod+bder(1)*hcovar(3))/sqg_c
  hcurl(3)=(dB_vartheta_c_dr/bmod-bder(1)*hcovar(2))/sqg_c
!
  end subroutine magfie_can
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine magfie_boozer(x,bmod,sqrtg,bder,hcovar,hctrvr,hcurl)
!
! Computes magnetic field module in units of the magnetic code  - bmod,
! square root of determinant of the metric tensor               - sqrtg,
! derivatives of the logarythm of the magnetic field module
! over coordinates                                              - bder,
! covariant componets of the unit vector of the magnetic
! field direction                                               - hcovar,
! contravariant components of this vector                       - hctrvr,
! contravariant component of the curl of this vector            - hcurl
! Order of coordinates is the following: x(1)=s (normalized toroidal flux),
! x(2)=vartheta_B (Boozer's poloidal angle), x(3)=varphi_B (Boozer's toroidal angle).
!
!  Input parameters:
!            formal:  x(3)             - array of Boozer coordinates
!  Output parameters:
!            formal:  bmod
!                     sqrtg
!                     bder(3)          - derivatives of $\log(B)$
!                     hcovar(3)        - covariant components of unit vector $\bh$ along $\bB$
!                     hctrvr(3)        - contra-variant components of unit vector $\bh$ along $\bB$
!                     hcurl(3)         - contra-variant components of curl of $\bh$
!
!  Called routines: splint_boozer_coord
!
  use vector_potentail_mod, only : torflux
!
  implicit none
!
  double precision :: bmod,sqrtg
  double precision, dimension(3) :: x,bder,hcovar,hctrvr,hcurl
!
  double precision :: r,vartheta_B,varphi_B,                                       &
                      A_phi,A_theta,dA_phi_dr,dA_theta_dr,d2A_phi_dr2,d3A_phi_dr3, &
                      B_vartheta_B,dB_vartheta_B,d2B_vartheta_B,                   &
                      B_varphi_B,dB_varphi_B,d2B_varphi_B,Bmod_B,B_r
  double precision, dimension(3) :: dBmod_B,dB_r
  double precision, dimension(6) :: d2Bmod_B,d2B_r
!
  double precision :: aiota,Bctrvr_theta,Bctrvr_phi,sqrtgbmod
!
  r=x(1)
  vartheta_B=x(2)
  varphi_B=x(3)
!
  call splint_boozer_coord(r,vartheta_B,varphi_B,                                       &
                           A_theta,A_phi,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                           B_vartheta_B,dB_vartheta_B,d2B_vartheta_B,                   &
                           B_varphi_B,dB_varphi_B,d2B_varphi_B,                         &
                           Bmod_B,dBmod_B,d2Bmod_B,                                     &
                           B_r,dB_r,d2B_r)
!
  aiota=-dA_phi_dr/dA_theta_dr
!
  bmod=Bmod_B
  bder=dBmod_B/Bmod_B
!
  sqrtg=(aiota*B_vartheta_B+B_varphi_B)/bmod**2*torflux
!
  Bctrvr_phi=dA_theta_dr/sqrtg
  Bctrvr_theta=aiota*Bctrvr_phi
  hctrvr(1)=0.d0
  hctrvr(2)=Bctrvr_theta/bmod
  hctrvr(3)=Bctrvr_phi/bmod
!
  hcovar(1)=B_r/bmod
  hcovar(2)=B_vartheta_B/bmod
  hcovar(3)=B_varphi_B/bmod
!
  sqrtgbmod=sqrtg*bmod
  hcurl(1)=(B_vartheta_B*bder(3)-B_varphi_B*bder(2))/sqrtgbmod
  hcurl(2)=(B_varphi_B*bder(1)-B_r*bder(3)+dB_r(3)-dB_varphi_B)/sqrtgbmod
  hcurl(3)=(B_r*bder(2)-B_vartheta_B*bder(1)+dB_vartheta_B-dB_r(2))/sqrtgbmod
!
  end subroutine magfie_boozer


      DOUBLE PRECISION FUNCTION PYTHAG(A,B)
      DOUBLE PRECISION A,B
C
C     FINDS SQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
C
      DOUBLE PRECISION P,R,S,T,U
      P = MAX(ABS(A),ABS(B))
      IF (P .EQ. 0.0D0) GO TO 20
      R = (MIN(ABS(A),ABS(B))/P)**2
   10 CONTINUE
         T = 4.0D0 + R
         IF (T .EQ. 4.0D0) GO TO 20
         S = R/T
         U = 1.0D0 + 2.0D0*S
         P = U*P
         R = (S/U)**2 * R
      GO TO 10
   20 PYTHAG = P
      RETURN
      END


!======================================================================!
  real function UserURms(grid, y)
!----------------------------------------------------------------------!
!   Prescribes mean streamwise velocity fluctuations for the channel.  !
!----------------------------------------------------------------------!
  implicit none
!-----------------------------[Arguments]------------------------------!
  real :: y
!======================================================================!
!   Wall is at y=0, and centerline at y=1                              !
!----------------------------------------------------------------------!

  UserURms =                                                        &
   +4.341229e+003  * y**9  -  2.218901e+004  * y**8                 &
   +4.851211e+004  * y**7  -  5.923957e+004  * y**6                 &
   +4.425061e+004  * y**5  -  2.080003e+004  * y**4                 &
   +6.078162e+003  * y**3  -  1.039484e+003  * y**2                 &
   +8.685630e+001  * y**1  -  6.519220e-002

  end function


      FUNCTION DIAGI(IALPHA,IBETA,EIGA,XY,NMOS)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION XY(NMECI,NMECI,NMECI,NMECI), EIGA(NMECI),
     1IALPHA(NMOS), IBETA(NMOS)
************************************************************************
*
*  CALCULATES THE ENERGY OF A MICROSTATE DEFINED BY IALPHA AND IBETA
*
************************************************************************
      X=0.0D0
      DO 20 I=1,NMOS
         IF (IALPHA(I).NE.0)THEN
            X=X+EIGA(I)
            DO 10  J=1,NMOS
               X=X+((XY(I,I,J,J)-XY(I,J,I,J))*IALPHA(J)*0.5D0 +
     1        (XY(I,I,J,J)            )*IBETA(J))
   10       CONTINUE
         ENDIF
   20 CONTINUE
      DO 40 I=1,NMOS
         IF (IBETA(I).NE.0) THEN
            X=X+EIGA(I)
            DO 30 J=1,I
   30       X=X+(XY(I,I,J,J)-XY(I,J,I,J))*IBETA(J)
         ENDIF
   40 CONTINUE
      DIAGI=X
      RETURN
      END


      SUBROUTINE PROCES (X)
C
      INTEGER          AXES,AXIS,GP,PRJECT
      REAL             X(3,1),XMIN(3),XMAX(3),MIN,MAX
      DOUBLE PRECISION SUM,V(3)
      COMMON /CONDAS/  CONSTS(5)
      COMMON /BLANK /  SKPCOM(5),NGPSET
      COMMON /XXPARM/  PBUFSZ,PLOTER(5),PENPAP(30),SCALE(5),AXES(6),
     1                 ALPHA,BETA,GAMMA,BETA13,BETA2,VIEW(4),
     2                 VANPUT(8),PRJECT
      COMMON /RSTXXX/  CSTM(3,3),MIN(3),MAX(3),D(3),AVER(3),
     1                 AXIS(3),SIGN(3)
      COMMON /DRWAXS/  G(3,3)
      EQUIVALENCE      (CONSTS(3),RAD)
C
C     INITIALIZATION.
C
      DO 10 I = 1,3
      AXIS(I) = IABS(AXES(I))
      SIGN(I) = 1.
      IF (AXES(I) .LT. 0) SIGN(I) = -1.
      MIN(I)  = +1.E+20
      MAX(I)  = -1.E+20
      IF (PRJECT  .NE. 3) GO TO 10
      XMIN(I) = +1.E+20
      XMAX(I) = -1.E+20
   10 CONTINUE
C
C     CALCULATE THE CO-ORDINATE SYSTEM ROTATION MATRIX.
C
      IF (BETA .GT. -1.E+10) GO TO 20
      IF (PRJECT .NE. 2) BETA = BETA13
      IF (PRJECT .EQ. 2) BETA = BETA2
   20 SINA = SIN(ALPHA/RAD)
      SINB = SIN(BETA /RAD)
      SING = SIN(GAMMA/RAD)
      COSA = COS(ALPHA/RAD)
      COSB = COS(BETA /RAD)
      COSG = COS(GAMMA/RAD)
C
      CSTM(1,1) = COSB*COSG
      CSTM(2,1) = COSA*SING + SINA*SINB*COSG
      CSTM(3,1) = SINA*SING - COSA*SINB*COSG
      CSTM(1,2) =-COSB*SING
      CSTM(2,2) = COSA*COSG - SINA*SINB*SING
      CSTM(3,2) = SINA*COSG + COSA*SINB*SING
      CSTM(1,3) = SINB
      CSTM(2,3) =-SINA*COSB
      CSTM(3,3) = COSA*COSB
C
C     SWITCH AXES + ROTATE THE GRID POINT CO-ORDINATES.
C
      DO 60 GP = 1,NGPSET
      DO 30  I = 1,3
      J    = AXIS(I)
      V(I) = SIGN(I)*X(J,GP)
      IF (PRJECT .NE. 3) GO TO 30
      VAL  = V(I)
      XMIN(I) = AMIN1(XMIN(I),VAL)
      XMAX(I) = AMAX1(XMAX(I),VAL)
   30 CONTINUE
      DO 50 J = 1,3
      SUM = 0.D0
      DO 40 I = 1,3
      SUM = SUM + CSTM(J,I)*V(I)
   40 CONTINUE
      VAL = SUM
      X(J,GP) = VAL
      MIN(J)  = AMIN1(MIN(J),VAL)
      MAX(J)  = AMAX1(MAX(J),VAL)
   50 CONTINUE
   60 CONTINUE
C
C     CALCULATE THE MINIMA-MAXIMA DIFFERENCES + AVERAGES.
C
      DO 70 I = 1,3
      IF (PRJECT .NE. 3) D(I) =  MAX(I) -  MIN(I)
      IF (PRJECT .EQ. 3) D(I) = XMAX(I) - XMIN(I)
      AVER(I) = (MAX(I)+MIN(I))/2.
   70 CONTINUE
C
C     CREATE A X-Y-Z UNIT COORDINATES IN /DRWAXS/ FOR VIEW PLOTTING
C
      DO 90 I = 1,9
   90 G(I,1) = 0.0
      G(1,1) = 1.0
      G(2,2) = 1.0
      G(3,3) = 1.0
C
      DO 130 GP = 1,3
      DO 100  I = 1,3
      J    = AXIS(I)
      V(I) = SIGN(I)*G(J,GP)
  100 CONTINUE
      DO 120 J = 1,3
      SUM = 0.D0
      DO 110 I = 1,3
      SUM = SUM + CSTM(J,I)*V(I)
  110 CONTINUE
  120 G(J,GP) = SUM
  130 CONTINUE
C
      RETURN
      END


      double complex function A51mpppp(j1,j2,j3,j4,j5,za,zb)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5
C----Eq.(4) of hep-ph/9302280v1 of BDK multiplied by 16*pi^2*(-i)*(-1)
C--- to give (16*pi^2)*(-i)*A^{[1/2]}_{5;1}
      A51mpppp=-((s(j2,j3)+s(j3,j4)+s(j4,j5))*zb(j2,j5)**2
     & -zb(j2,j4)*za(j4,j3)*zb(j3,j5)*zb(j2,j5)
     & -zb(j1,j2)*zb(j1,j5)/(za(j1,j2)*za(j1,j5))
     & *(za(j1,j2)**2*za(j1,j3)**2*zb(j2,j3)/za(j2,j3)
     &  +za(j1,j3)**2*za(j1,j4)**2*zb(j3,j4)/za(j3,j4)
     &  +za(j1,j4)**2*za(j1,j5)**2*zb(j4,j5)/za(j4,j5)))
     & /(3d0*zb(j1,j2)*za(j2,j3)*za(j3,j4)*za(j4,j5)*zb(j5,j1))
      return
      end


subroutine calc_core_radiativefeedback(j)

  use embryodata
  implicit none

  integer, intent(in) :: j

  real :: core_energy,embryo_energy

  ! evaluate radiative feedback of core formation on envelope OpenmP FLAGS!
  core_energy = embryo(j)%mcore*embryo(j)%mcore/embryo(j)%rcore
  embryo_energy = embryo(j)%m*embryo(j)%m/embryo(j)%r

  ! If energy released in core formation greater than envelope binding energy, destroy the embryo
  if(core_energy>embryo_energy) then
     embryo(j)%r =0.0
     embryo(j)%M = 0.0
  endif

end subroutine calc_core_radiativefeedback


!********************************************************************************
!* This file is part of:
!* BAFFLE (https://github.com/ATHannington/BAFFLE)
!* BAFFLE: BAsic Fortran FLuids Engine
!*
!* BAFFLE:
!* Copyright (C) 2017 Andrew Hannington (ath4@st-andrews.ac.uk)
!*
!* This software is a derivative of work by Bert Vandenbroucke
!* (bert.vandenbroucke@gmail.com)
!* Find more work by Bert Vandenbroucke at: (https://github.com/bwvdnbro)
!*
!* BAFFLE is a free software: you can redistribute it and/or modify it under the
!* terms of the GNU Affero General Public License
!* as published by the Free Software Foundation, either version 3 of the License, or
!* (at your option) any later version.
!*
!* BAFFLE is distributed in the hope that it will
!* be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!* GNU Affero General Public License for more details.
!*
!* You should have received a copy of the GNU Affero General Public License
!* along with BAFFLE. If not, see
!* <http://www.gnu.org/licenses/>.
!********************************************************************************

!********************************************************************************
!* @file cell_wide_slope_limiter_3D.f90
!*
!* @Seperate advanced slope limiter for slope of primitive variables calculated in
!* get_gradients_subroutine_#.f90. 3D version : Fortran 90 version
!*
!* @author Andrew Hannington (ath4@st-andrews.ac.uk)
!********************************************************************************

!-------------------------------------------------------------------------------
!*******************************************************************************
!-------------------------------------------------------------------------------
! Implementinmg Cell-Wide slop limiter, where
!
! Grad-vec = alpha* grad_dum-vec
!
! alpha = max(0, min (1,beta*min[(phi_ngb,max - phi)/(phi_ext,max - phi), (phi - phi_ngb,min)/(phi - phi_ext,min)]))
!
!The Max(0,(~)) term ensures gradient is set to zero at turning points, as alpha!>=0
!
! phi_ngb,max = max_j[phi_j]
! phi_ngb,min = min_j[phi_j]
!
! phi_ext,max = max_j[phi+grad_dum-vec·Del_x_j-vec]
! phi_ext,min = min_j[phi+grad_dum-vec·Del_x_j-vec]
!
! phi_j is the variable (rho,ux,uy,uz,p) in neighbour (ngb) cell j
! Del_x_j -vec is the vector pointing between midpoint of the cell to the midpoint of the face between cell and neighbour
! Beta is a constant: beta=0.5 is the most conservative (stable) value allowed!
!
!-------------------------------------------------------------------------------
!*******************************************************************************
!-------------------------------------------------------------------------------
subroutine slope_limiter(i,j,k,time)
	use constants
	implicit none

		Real*8,intent(in) :: time
		Integer,intent(in) :: i,j,k					!Incoming integers from gradients subroutine. This selects the cell who's gradient has just been calculated.
		Integer :: idum,jdum,kdum					!These dummy i,j,k integers hold the location of the neighbour cell for the specific neighbour on a given axis
		Integer :: ngb							!Identifies the number of neighbour cells.	*** 2=> 1D		4=>2d		6=>3d ***
		Real*8, allocatable,dimension(:) :: d_array,ux_array,uy_array, &
					& uz_array,p_array			!Holds the variables for the neighbour cells for the respective variable such that the min and max value can be 										determined

		Real*8 :: d_ngb_min,ux_ngb_min,uy_ngb_min,&
			& uz_ngb_min,p_ngb_min					!Holds the minimum value for each variable IN *** NEIGHBOUR CELLS ***
		Real*8 :: d_ngb_max,ux_ngb_max,uy_ngb_max, &
			& uz_ngb_max,p_ngb_max					!Holds the maximum value for each variable IN *** NEIGHBOUR CELLS ***

		Real*8 :: d_ext_min,ux_ext_min,uy_ext_min,&
			& uz_ext_min,p_ext_min					!Holds the minimum value for each variable *** FROM EXTRAPOLATION ***
		Real*8 :: d_ext_max,ux_ext_max,uy_ext_max, &
			& uz_ext_max,p_ext_max					!Holds the maximum value for each variable *** FROM EXTRAPOLATION ***

		Real*8,allocatable,dimension(:) :: d_ext_array,ux_ext_array, &
			& uy_ext_array, uz_ext_array,p_ext_array		!Holds the calculated value for each variable *** FROM EXTRAPOLATION *** for all neighbours, so that the min or max may 										be calculated

		Real*8 :: d_cent,ux_cent,uy_cent,&
			& uz_cent,p_cent					!Holds the value for each variable *** IN CENTRE OF CELL ***

		Real*8, dimension(3) :: Del_x_vec				!Holds the centre to face centre vector
		Real*8 :: delx,dely,delz					!Distances for Del_x_vector between cell centre and face centre

		Real*8,dimension(3) :: g_d_vec,g_ux_vec,g_uy_vec, &		!Holds the gradient for each vector along each axis in vector form. These are the **grad_dum** vectors!!
					& g_uz_vec,g_p_vec
		Real*8 :: alpha, beta						!Alpha the scaling variable for the gradients, as defined above. Beta a constant setting how conservative the code is!

		Integer :: num							!Integer number that ensures all of the variables in a given direction are given the same position in arrays.

!-------------------------------------------------------------------------------
!#####				SETUP					########
!-------------------------------------------------------------------------------
!Set conservative beta:
	beta=0.5d0
!Initialise alpha as zero to begin with:
	alpha=0.d0

!Set number of neighbour cells:
!*** 2=> 1D		4=>2d		6=>3d ***
	ngb=6

!Set Dimensions of arrays that are dependent of number of neighbours:
	allocate(d_array(ngb))
	allocate(ux_array(ngb))
	allocate(uy_array(ngb))
	allocate(uz_array(ngb))
	allocate(p_array(ngb))

	allocate(d_ext_array(ngb))
	allocate(ux_ext_array(ngb))
	allocate(uy_ext_array(ngb))
	allocate(uz_ext_array(ngb))
	allocate(p_ext_array(ngb))

!Fill Gradient vector for cell being analysed:
!These are the **grad_dum** vectors!!
	g_d_vec = (/cells(i,j,k,gdxn),cells(i,j,k,gdyn),cells(i,j,k,gdzn)/)
	g_ux_vec = (/cells(i,j,k,guxxn),cells(i,j,k,guxyn),cells(i,j,k,guxzn)/)
	g_uy_vec = (/cells(i,j,k,guyxn),cells(i,j,k,guyyn),cells(i,j,k,guyzn)/)
	g_uz_vec = (/cells(i,j,k,guzxn),cells(i,j,k,guzyn),cells(i,j,k,guzzn)/)
	g_p_vec = (/cells(i,j,k,gpxn),cells(i,j,k,gpyn),cells(i,j,k,gpzn)/)

!Fill central values of the cell:
!These are the phi values:

	d_cent = cells(i,j,k,rhon)
	ux_cent = cells(i,j,k,uxn)
	uy_cent = cells(i,j,k,uyn)
	uz_cent = cells (i,j,k,uzn)
	p_cent = cells (i,j,k,pn)

!-------------------------------------------------------------------------------
!#####			X-Axis Neighbours				########
!-------------------------------------------------------------------------------

!-ve x-face direction neighbour
	idum = i-1
	jdum = j
	kdum = k

!Set position in array number:
	num=1

!Fill variable array entries for this neighbour:
! This is equivalent to entering the first value (j=1) into the phi_j, so that the min and max can be taken later.
	d_array(num) = cells(idum,jdum,kdum,rhon)
	ux_array(num) = cells(idum,jdum,kdum,uxn)
	uy_array(num) = cells(idum,jdum,kdum,uyn)
	uz_array(num) = cells(idum,jdum,kdum,uzn)
	p_array(num) = cells(idum,jdum,kdum,pn)

! *** EXTRAPOLATION ***:
!Calculate cell centre to cell face distances:
	delx = (cells(i,j,k,xn) - cells(idum,jdum,kdum,xn))/2.d0
	dely = (cells(i,j,k,yn) - cells(idum,jdum,kdum,yn))/2.d0
	delz = (cells(i,j,k,zn) - cells(idum,jdum,kdum,zn))/2.d0

!Fill temporary cell centre to face centre vector:
	Del_x_vec = (/delx,dely,delz/)

!Make extrapolations to cell face:
! " phi+grad_dum-vec·Del_x_j-vec "
!	d_ext_array(num) = d_cent + dot_product(g_d_vec,Del_x_vec)
!	ux_ext_array(num) = ux_cent + dot_product(g_ux_vec,Del_x_vec)
!	uy_ext_array(num) = uy_cent + dot_product(g_uy_vec,Del_x_vec)
!	uz_ext_array(num) = uz_cent + dot_product(g_uz_vec,Del_x_vec)
!	p_ext_array(num) = p_cent + dot_product(g_p_vec,Del_x_vec)
	d_ext_array(num) = d_cent + ((g_d_vec(1)*Del_x_vec(1))+(g_d_vec(2)*Del_x_vec(2))+(g_d_vec(3)*Del_x_vec(3)))
	ux_ext_array(num) = ux_cent + ((g_ux_vec(1)*Del_x_vec(1))+(g_ux_vec(2)*Del_x_vec(2))+(g_ux_vec(3)*Del_x_vec(3)))
	uy_ext_array(num) = uy_cent + ((g_uy_vec(1)*Del_x_vec(1))+(g_uy_vec(2)*Del_x_vec(2))+(g_uy_vec(3)*Del_x_vec(3)))
	uz_ext_array(num) = uz_cent + ((g_uz_vec(1)*Del_x_vec(1))+(g_uz_vec(2)*Del_x_vec(2))+(g_uz_vec(3)*Del_x_vec(3)))
	p_ext_array(num) = p_cent + ((g_p_vec(1)*Del_x_vec(1))+(g_p_vec(2)*Del_x_vec(2))+(g_p_vec(3)*Del_x_vec(3)))
!-------------------------------------------------------------------------------

!+ve x-face dire! phi_ngb,min = min_j[phi_j]ction neighbour
	idum = i+1
	jdum = j
	kdum = k

!Set position in array number:
	num=2

!Fill variable array entries for this neighbour:
! This is equivalent to entering the first value (j=1) into the phi_j, so that the min and max can be taken later.
	d_array(num) = cells(idum,jdum,kdum,rhon)
	ux_array(num) = cells(idum,jdum,kdum,uxn)
	uy_array(num) = cells(idum,jdum,kdum,uyn)
	uz_array(num) = cells(idum,jdum,kdum,uzn)
	p_array(num) = cells(idum,jdum,kdum,pn)

! *** EXTRAPOLATION ***:
!Calculate cell centre to cell face distances:
	delx = (cells(i,j,k,xn) - cells(idum,jdum,kdum,xn))/2.d0
	dely = (cells(i,j,k,yn) - cells(idum,jdum,kdum,yn))/2.d0
	delz = (cells(i,j,k,zn) - cells(idum,jdum,kdum,zn))/2.d0

!Fill temporary cell centre to face centre vector:
	Del_x_vec = (/delx,dely,delz/)

!Make extrapolations to cell face:
! " phi+grad_dum-vec·Del_x_j-vec "
!	d_ext_array(num) = d_cent + dot_product(g_d_vec,Del_x_vec)
!	ux_ext_array(num) = ux_cent + dot_product(g_ux_vec,Del_x_vec)
!	uy_ext_array(num) = uy_cent + dot_product(g_uy_vec,Del_x_vec)
!	uz_ext_array(num) = uz_cent + dot_product(g_uz_vec,Del_x_vec)
!	p_ext_array(num) = p_cent + dot_product(g_p_vec,Del_x_vec)
	d_ext_array(num) = d_cent + ((g_d_vec(1)*Del_x_vec(1))+(g_d_vec(2)*Del_x_vec(2))+(g_d_vec(3)*Del_x_vec(3)))
	ux_ext_array(num) = ux_cent + ((g_ux_vec(1)*Del_x_vec(1))+(g_ux_vec(2)*Del_x_vec(2))+(g_ux_vec(3)*Del_x_vec(3)))
	uy_ext_array(num) = uy_cent + ((g_uy_vec(1)*Del_x_vec(1))+(g_uy_vec(2)*Del_x_vec(2))+(g_uy_vec(3)*Del_x_vec(3)))
	uz_ext_array(num) = uz_cent + ((g_uz_vec(1)*Del_x_vec(1))+(g_uz_vec(2)*Del_x_vec(2))+(g_uz_vec(3)*Del_x_vec(3)))
	p_ext_array(num) = p_cent + ((g_p_vec(1)*Del_x_vec(1))+(g_p_vec(2)*Del_x_vec(2))+(g_p_vec(3)*Del_x_vec(3)))

!-------------------------------------------------------------------------------
!#####			y-Axis Neighbours				########
!-------------------------------------------------------------------------------

!-ve x-face direction neighbour
	idum = i
	jdum = j-1
	kdum = k

!Set position in array number:
	num=3

!Fill variable array entries for this neighbour:
! This is equivalent to entering the first value (j=1) into the phi_j, so that the min and max can be taken later.
	d_array(num) = cells(idum,jdum,kdum,rhon)
	ux_array(num) = cells(idum,jdum,kdum,uxn)
	uy_array(num) = cells(idum,jdum,kdum,uyn)
	uz_array(num) = cells(idum,jdum,kdum,uzn)
	p_array(num) = cells(idum,jdum,kdum,pn)

! *** EXTRAPOLATION ***:
!Calculate cell centre to cell face distances:
	delx = (cells(i,j,k,xn) - cells(idum,jdum,kdum,xn))/2.d0
	dely = (cells(i,j,k,yn) - cells(idum,jdum,kdum,yn))/2.d0
	delz = (cells(i,j,k,zn) - cells(idum,jdum,kdum,zn))/2.d0

!Fill temporary cell centre to face centre vector:
	Del_x_vec = (/delx,dely,delz/)

!Make extrapolations to cell face:
! " phi+grad_dum-vec·Del_x_j-vec "
!	d_ext_array(num) = d_cent + dot_product(g_d_vec,Del_x_vec)
!	ux_ext_array(num) = ux_cent + dot_product(g_ux_vec,Del_x_vec)
!	uy_ext_array(num) = uy_cent + dot_product(g_uy_vec,Del_x_vec)
!	uz_ext_array(num) = uz_cent + dot_product(g_uz_vec,Del_x_vec)
!	p_ext_array(num) = p_cent + dot_product(g_p_vec,Del_x_vec)
	d_ext_array(num) = d_cent + ((g_d_vec(1)*Del_x_vec(1))+(g_d_vec(2)*Del_x_vec(2))+(g_d_vec(3)*Del_x_vec(3)))
	ux_ext_array(num) = ux_cent + ((g_ux_vec(1)*Del_x_vec(1))+(g_ux_vec(2)*Del_x_vec(2))+(g_ux_vec(3)*Del_x_vec(3)))
	uy_ext_array(num) = uy_cent + ((g_uy_vec(1)*Del_x_vec(1))+(g_uy_vec(2)*Del_x_vec(2))+(g_uy_vec(3)*Del_x_vec(3)))
	uz_ext_array(num) = uz_cent + ((g_uz_vec(1)*Del_x_vec(1))+(g_uz_vec(2)*Del_x_vec(2))+(g_uz_vec(3)*Del_x_vec(3)))
	p_ext_array(num) = p_cent + ((g_p_vec(1)*Del_x_vec(1))+(g_p_vec(2)*Del_x_vec(2))+(g_p_vec(3)*Del_x_vec(3)))

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

!+ve x-face dire! phi_ngb,min = min_j[phi_j]ction neighbour
	idum = i
	jdum = j+1
	kdum = k

!Set position in array number:
	num=4

!Fill variable array entries for this neighbour:
! This is equivalent to entering the first value (j=1) into the phi_j, so that the min and max can be taken later.
	d_array(num) = cells(idum,jdum,kdum,rhon)
	ux_array(num) = cells(idum,jdum,kdum,uxn)
	uy_array(num) = cells(idum,jdum,kdum,uyn)
	uz_array(num) = cells(idum,jdum,kdum,uzn)
	p_array(num) = cells(idum,jdum,kdum,pn)

! *** EXTRAPOLATION ***:
!Calculate cell centre to cell face distances:
	delx = (cells(i,j,k,xn) - cells(idum,jdum,kdum,xn))/2.d0
	dely = (cells(i,j,k,yn) - cells(idum,jdum,kdum,yn))/2.d0
	delz = (cells(i,j,k,zn) - cells(idum,jdum,kdum,zn))/2.d0

!Fill temporary cell centre to face centre vector:
	Del_x_vec = (/delx,dely,delz/)

!Make extrapolations to cell face:
! " phi+grad_dum-vec·Del_x_j-vec "
!	d_ext_array(num) = d_cent + dot_product(g_d_vec,Del_x_vec)
!	ux_ext_array(num) = ux_cent + dot_product(g_ux_vec,Del_x_vec)
!	uy_ext_array(num) = uy_cent + dot_product(g_uy_vec,Del_x_vec)
!	uz_ext_array(num) = uz_cent + dot_product(g_uz_vec,Del_x_vec)
!	p_ext_array(num) = p_cent + dot_product(g_p_vec,Del_x_vec)
	d_ext_array(num) = d_cent + ((g_d_vec(1)*Del_x_vec(1))+(g_d_vec(2)*Del_x_vec(2))+(g_d_vec(3)*Del_x_vec(3)))
	ux_ext_array(num) = ux_cent + ((g_ux_vec(1)*Del_x_vec(1))+(g_ux_vec(2)*Del_x_vec(2))+(g_ux_vec(3)*Del_x_vec(3)))
	uy_ext_array(num) = uy_cent + ((g_uy_vec(1)*Del_x_vec(1))+(g_uy_vec(2)*Del_x_vec(2))+(g_uy_vec(3)*Del_x_vec(3)))
	uz_ext_array(num) = uz_cent + ((g_uz_vec(1)*Del_x_vec(1))+(g_uz_vec(2)*Del_x_vec(2))+(g_uz_vec(3)*Del_x_vec(3)))
	p_ext_array(num) = p_cent + ((g_p_vec(1)*Del_x_vec(1))+(g_p_vec(2)*Del_x_vec(2))+(g_p_vec(3)*Del_x_vec(3)))

!-------------------------------------------------------------------------------
!#####			z-Axis Neighbours				########
!-------------------------------------------------------------------------------

!-ve x-face direction neighbour
	idum = i
	jdum = j
	kdum = k-1

!Set position in array number:
	num=5

!Fill variable array entries for this neighbour:
! This is equivalent to entering the first value (j=1) into the phi_j, so that the min and max can be taken later.
	d_array(num) = cells(idum,jdum,kdum,rhon)
	ux_array(num) = cells(idum,jdum,kdum,uxn)
	uy_array(num) = cells(idum,jdum,kdum,uyn)
	uz_array(num) = cells(idum,jdum,kdum,uzn)
	p_array(num) = cells(idum,jdum,kdum,pn)

! *** EXTRAPOLATION ***:
!Calculate cell centre to cell face distances:
	delx = (cells(i,j,k,xn) - cells(idum,jdum,kdum,xn))/2.d0
	dely = (cells(i,j,k,yn) - cells(idum,jdum,kdum,yn))/2.d0
	delz = (cells(i,j,k,zn) - cells(idum,jdum,kdum,zn))/2.d0

!Fill temporary cell centre to face centre vector:
	Del_x_vec = (/delx,dely,delz/)

!Make extrapolations to cell face:
! " phi+grad_dum-vec·Del_x_j-vec "
!	d_ext_array(num) = d_cent + dot_product(g_d_vec,Del_x_vec)
!	ux_ext_array(num) = ux_cent + dot_product(g_ux_vec,Del_x_vec)
!	uy_ext_array(num) = uy_cent + dot_product(g_uy_vec,Del_x_vec)
!	uz_ext_array(num) = uz_cent + dot_product(g_uz_vec,Del_x_vec)
!	p_ext_array(num) = p_cent + dot_product(g_p_vec,Del_x_vec)
	d_ext_array(num) = d_cent + ((g_d_vec(1)*Del_x_vec(1))+(g_d_vec(2)*Del_x_vec(2))+(g_d_vec(3)*Del_x_vec(3)))
	ux_ext_array(num) = ux_cent + ((g_ux_vec(1)*Del_x_vec(1))+(g_ux_vec(2)*Del_x_vec(2))+(g_ux_vec(3)*Del_x_vec(3)))
	uy_ext_array(num) = uy_cent + ((g_uy_vec(1)*Del_x_vec(1))+(g_uy_vec(2)*Del_x_vec(2))+(g_uy_vec(3)*Del_x_vec(3)))
	uz_ext_array(num) = uz_cent + ((g_uz_vec(1)*Del_x_vec(1))+(g_uz_vec(2)*Del_x_vec(2))+(g_uz_vec(3)*Del_x_vec(3)))
	p_ext_array(num) = p_cent + ((g_p_vec(1)*Del_x_vec(1))+(g_p_vec(2)*Del_x_vec(2))+(g_p_vec(3)*Del_x_vec(3)))

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

!+ve x-face dire! phi_ngb,min = min_j[phi_j]ction neighbour
	idum = i
	jdum = j
	kdum = k+1

!Set position in array number:
	num=6

!Fill variable array entries for this neighbour:
! This is equivalent to entering the first value (j=1) into the phi_j, so that the min and max can be taken later.
	d_array(num) = cells(idum,jdum,kdum,rhon)
	ux_array(num) = cells(idum,jdum,kdum,uxn)
	uy_array(num) = cells(idum,jdum,kdum,uyn)
	uz_array(num) = cells(idum,jdum,kdum,uzn)
	p_array(num) = cells(idum,jdum,kdum,pn)

! *** EXTRAPOLATION ***:
!Calculate cell centre to cell face distances:
	delx = (cells(i,j,k,xn) - cells(idum,jdum,kdum,xn))/2.d0
	dely = (cells(i,j,k,yn) - cells(idum,jdum,kdum,yn))/2.d0
	delz = (cells(i,j,k,zn) - cells(idum,jdum,kdum,zn))/2.d0

!Fill temporary cell centre to face centre vector:
	Del_x_vec = (/delx,dely,delz/)

!Make extrapolations to cell face:
! " phi+grad_dum-vec·Del_x_j-vec "
!	d_ext_array(num) = d_cent + dot_product(g_d_vec,Del_x_vec)
!	ux_ext_array(num) = ux_cent + dot_product(g_ux_vec,Del_x_vec)
!	uy_ext_array(num) = uy_cent + dot_product(g_uy_vec,Del_x_vec)
!	uz_ext_array(num) = uz_cent + dot_product(g_uz_vec,Del_x_vec)
!	p_ext_array(num) = p_cent + dot_product(g_p_vec,Del_x_vec)
	d_ext_array(num) = d_cent + ((g_d_vec(1)*Del_x_vec(1))+(g_d_vec(2)*Del_x_vec(2))+(g_d_vec(3)*Del_x_vec(3)))
	ux_ext_array(num) = ux_cent + ((g_ux_vec(1)*Del_x_vec(1))+(g_ux_vec(2)*Del_x_vec(2))+(g_ux_vec(3)*Del_x_vec(3)))
	uy_ext_array(num) = uy_cent + ((g_uy_vec(1)*Del_x_vec(1))+(g_uy_vec(2)*Del_x_vec(2))+(g_uy_vec(3)*Del_x_vec(3)))
	uz_ext_array(num) = uz_cent + ((g_uz_vec(1)*Del_x_vec(1))+(g_uz_vec(2)*Del_x_vec(2))+(g_uz_vec(3)*Del_x_vec(3)))
	p_ext_array(num) = p_cent + ((g_p_vec(1)*Del_x_vec(1))+(g_p_vec(2)*Del_x_vec(2))+(g_p_vec(3)*Del_x_vec(3)))

!-------------------------------------------------------------------------------
!#####			FINAL CALCULATION AND GRADIENT ADJUST		########
!-------------------------------------------------------------------------------
!Minimum values of phi neighbours:
! phi_ngb,min = min_j[phi_j]
		d_ngb_min = minval(d_array)
		ux_ngb_min = minval(ux_array)
		uy_ngb_min = minval(uy_array)
		uz_ngb_min = minval(uz_array)
		p_ngb_min = minval(p_array)

!Maximum values of phi neighbours:
! phi_ngb,max = max_j[phi_j]
		d_ngb_max = maxval(d_array)
		ux_ngb_max = maxval(ux_array)
		uy_ngb_max = maxval(uy_array)
		uz_ngb_max = maxval(uz_array)
		p_ngb_max = maxval(p_array)

!Minimum values of phi EXTRAPOLATED:
! phi_ext,MIN = MIN_j[phi+grad_dum-vec·Del_x_j-vec]
		d_ext_min = minval(d_ext_array)
		ux_ext_min = minval(ux_ext_array)
		uy_ext_min = minval(uy_ext_array)
		uz_ext_min = minval(uz_ext_array)
		p_ext_min = minval(p_ext_array)

!Maximum values of phi EXTRAPOLATED:
! phi_ext,max = max_j[phi+grad_dum-vec·Del_x_j-vec]
		d_ext_max = maxval(d_ext_array)
		ux_ext_max = maxval(ux_ext_array)
		uy_ext_max = maxval(uy_ext_array)
		uz_ext_max = maxval(uz_ext_array)
		p_ext_max = maxval(p_ext_array)

!Calculate ALPHA for each variable and adjust gradient:
! alpha = minval (1,beta*minval[(phi_ngb,max - phi)/(phi_ext,max - phi), (phi - phi_ngb,min)/(phi - phi_ext,min)])
! Grad-vec = alpha* grad_dum-vec

!Density:
 alpha = max(0.d0,min(1.d0,beta*min((d_ngb_max - d_cent)/(d_ext_max - d_cent),(d_cent - d_ngb_min)/(d_cent - d_ext_min))))

 cells(i,j,k,gdxn) = alpha*g_d_vec(1)
 cells(i,j,k,gdyn) = alpha*g_d_vec(2)
 cells(i,j,k,gdzn) = alpha*g_d_vec(3)

!ux:
 alpha = max(0.d0,min(1.d0,beta*min((ux_ngb_max - ux_cent)/(ux_ext_max - ux_cent),(ux_cent - ux_ngb_min)/(ux_cent - ux_ext_min))))

 cells(i,j,k,guxxn) = alpha*g_ux_vec(1)
 cells(i,j,k,guxyn) = alpha*g_ux_vec(2)
 cells(i,j,k,guxzn) = alpha*g_ux_vec(3)

!uy:
 alpha = max(0.d0,min(1.d0,beta*min((uy_ngb_max - uy_cent)/(uy_ext_max - uy_cent),(uy_cent - uy_ngb_min)/(uy_cent - uy_ext_min))))

 cells(i,j,k,guyxn) = alpha*g_uy_vec(1)
 cells(i,j,k,guyyn) = alpha*g_uy_vec(2)
 cells(i,j,k,guyzn) = alpha*g_uy_vec(3)

!uz:
 alpha = max(0.d0,min(1.d0,beta*min((uz_ngb_max - uz_cent)/(uz_ext_max - uz_cent),(uz_cent - uz_ngb_min)/(uz_cent - uz_ext_min))))

 cells(i,j,k,guzxn) = alpha*g_uz_vec(1)
 cells(i,j,k,guzyn) = alpha*g_uz_vec(2)
 cells(i,j,k,guzzn) = alpha*g_uz_vec(3)

!p:
 alpha = max(0.d0,min(1.d0,beta*min((p_ngb_max - p_cent)/(p_ext_max - p_cent),(p_cent - p_ngb_min)/(p_cent - p_ext_min))))

 cells(i,j,k,gpxn) = alpha*g_p_vec(1)
 cells(i,j,k,gpyn) = alpha*g_p_vec(2)
 cells(i,j,k,gpzn) = alpha*g_p_vec(3)

end subroutine slope_limiter


module rhs
	use global_variables
    use derived_parameters
	implicit none

contains

    subroutine FEX(NEQ,T,Y,YDOT)
        implicit none
        integer, intent (in) :: NEQ ! Number of ODEs = 2*Number of Modes+1 (Number and Volume balance for each mode)
        double precision, intent (in) :: T
        double precision, intent (in) :: Y(NEQ)
        double precision, intent (out) :: YDOT(NEQ)
        double precision :: N((NEQ-1)/2), V_mode((NEQ-1)/2), v((NEQ-1)/2), dNdt_coag((NEQ-1)/2), dVdt_coag((NEQ-1)/2), frac((NEQ-1)/2,(NEQ-1)/2,(NEQ-1)/2), dNdt_nucl((NEQ-1)/2), dVdt_nucl((NEQ-1)/2) ! Number of modes = (NEQ-1)/2
        double precision :: dNdt_coag_term_1, dNdt_coag_term_2, dNdt_coag_term_3, dVdt_coag_term_2, dVdt_coag_term_3
		double precision :: B1, Dm, B3, cond_loss, B4
        double precision :: G_C((NEQ-1)/2), G_FM((NEQ-1)/2), dVdt_cond((NEQ-1)/2)

        integer :: i, j, k

        call read_inputfile()
		call derived_param()

		do k = 1, N_modes	! N_modes = NEQ/2 = Number of Modes
			! Y1 = N1; Y2 = V1; Y3 = N2; Y4 = V2; ...
			N(k) = Y(2*k-1) ! Total # conc. of mode k
			V_mode(k) = Y(2*k) ! Total volume of mode k
			if (k == 1) then
				v(k) = v_init(k) ! Volm. of a particle in mode 1
			else
				v(k) = V_mode(k)/N(k) ! Volm. of a particle in mode k
			end if
        end do

        !!!!!!!!!!!!!!!!!!!!!!!!!
        !!!!NUCLEATION TERMS!!!!!
        !!!!!!!!!!!!!!!!!!!!!!!!!
		dNdt_nucl = 0
		dVdt_nucl = 0
        if (flag_nucl == 1) then
			n1 = Y(NEQ)
			p1 = n1*(kB*Temp)
			S = p1/ps

			! Nucleation Rate
			if (S>1) then
				I_nucl = 2.0*(p1/((2.0*PI*m1*kB*Temp)**(1.0/2.0)))*(n1*vm**(2.0/3.0))*(((sigma*vm**(2.0/3.0))/(kB*Temp))**(1.0/2.0))*exp(-(16.0*PI*(sigma**3.0)*(vm**2.0))/(3*((kB*Temp)**3)*((log(S))**2.0)))
				dp_critical = 4.0*sigma*vm/(kB*Temp*log(S))
				v_critical = PI*(dp_critical**3.0)/6.0
				!v_critical = 2*vm
				!dp_critical = ((6.0/PI)*v_critical)**(1.0/3)
			else
				I_nucl = 0
				dp_critical = 0
			end if

			dNdt_nucl(1) = I_nucl*v_critical/v(1)
			dVdt_nucl(1) = dNdt_nucl(1)*v(1)
		end if

        !!!!!!!!!!!!!!!!!!!!!!!!!
        !!!!CONDENSATION TERMS!!!
        !!!!!!!!!!!!!!!!!!!!!!!!!
		dVdt_cond = 0
		cond_loss = 0
		if (flag_cond == 1) then
			B1 = ((36*PI)**(1.0/3))*vm*(ps/(kB*Temp))*((kB*Temp)/(2*PI*m1))**(1.0/2)
			Dm = ((8.0*kB*Temp/(PI*m1))**(1.0/2))
			B3 = ((48.0*PI*PI)**(1.0/3))*vm*(ps/(kB*Temp))*(lm/3)*Dm

			do k = 1, N_modes
				G_C(k) = B3*(v(k)**(1.0/3))*(S-1)
				G_FM(k) = B1*(v(k)**(2.0/3))*(S-1)

				dVdt_cond(k) = (1/((1/G_C(k))+(1/G_FM(k))))*N(k)
			end do

			cond_loss = 0
			do k = 1, N_modes
				cond_loss = cond_loss + dVdt_cond(k)/vm
			end do
		end if

        !!!!!!!!!!!!!!!!!!!!!!!!!
        !!!!COAGULATION TERMS!!!!
        !!!!!!!!!!!!!!!!!!!!!!!!!
        dNdt_coag = 0
        dVdt_coag = 0

		if (flag_coag == 1) then
			frac = fractn(N_modes,v) ! When particles in mode i and j collide, frac(i,j,k) gives fraction of resulting particle that lies in mode k

			do k = 1, N_modes

				! dN/dt coagulation terms
				dNdt_coag_term_1 = 0 ! Tracking loss of particles from mode k due to collision
				dNdt_coag_term_2 = 0 ! Tracking particles formed by collision of particles in Mode i with themselves which may possibly lie in Mode k
				dNdt_coag_term_3 = 0 ! Tracking particles formed by collision of particles in Mode i with Mode j (i=!j) which may possibly lie in Mode k

				! dV/dt coagulation terms
				dVdt_coag_term_2 = 0
				dVdt_coag_term_3 = 0

				if (k < N_modes) then ! All modes except last one
					do i = 1, N_modes
						dNdt_coag_term_1 = dNdt_coag_term_1 + (-beta(v(k),v(i))*N(i)*N(k)) ! Rate of collision of particles from mode k with other modes ! Note: There is no 1/2 factor in k-k collision as it also results in loss of 2 particles
						dNdt_coag_term_2 = dNdt_coag_term_2 + (1.0/2.0)*beta(v(i),v(i))*N(i)*N(i)*frac(i,i,k)
					end do

					do i = 2, N_modes
						do j = 1, i-1
							dNdt_coag_term_3 = dNdt_coag_term_3 + beta(v(j),v(i))*N(i)*N(j)*frac(i,j,k)
						end do
					end do

					dNdt_coag(k) = dNdt_coag_term_1 + dNdt_coag_term_2 + dNdt_coag_term_3
					dVdt_coag(k) = v(k)*dNdt_coag(k) ! Except for the last mode, coagulation will not result in volume change of a particle in a mode

				else ! Last Mode
					! dN/dt coagulation terms
					dNdt_coag_term_1 = dNdt_coag_term_1 + (-0.5*beta(v(k),v(k))*N(k)*N(k)) ! Note: There is no 1/2 factor as there is loss of only 1 particle when 2 particle in last mode collide among themselves (the newly formed particle will be in same mode)
					do i = 1, (N_modes-1)
						dNdt_coag_term_2 = dNdt_coag_term_2 + (1.0/2.0)*beta(v(i),v(i))*N(i)*N(i)*frac(i,i,k) ! Tracking particles formed by collision of particles in Mode i with themselves which may possibly lie in last mode.
					end do

					! when particles in mode j (j<k) collide with last mode, the resulting particle will lie in last mode. There is no change in # conc in last mode.
					if (N_modes > 2) then
						do i = 2, (N_modes-1)
							do j = 1, i-1
									dNdt_coag_term_3 = dNdt_coag_term_3 + beta(v(j),v(i))*N(i)*N(j)*frac(i,j,k) ! Tracking particles formed by collision of particles in Mode i with Mode j (i=!j) which may possibly lie in Mode k
							end do
						end do
					end if

					dNdt_coag(k) = dNdt_coag_term_1 + dNdt_coag_term_2 + dNdt_coag_term_3

					! dV/dt coagulation terms
					do i = 1, N_modes-1
						dVdt_coag_term_2 = dVdt_coag_term_2 + (0.5)*beta(v(i),v(i))*N(i)*N(i)*frac(i,i,k)*(v(k)) ! fracn. going to mode k is frac(i,i,k)
					end do

					do i = 2, N_modes
						do j = 1, i-1
							if (i == N_modes) then
								dVdt_coag_term_3 = dVdt_coag_term_3 + beta(v(j),v(i))*N(i)*N(j)*frac(i,j,k)*(v(j))
							else
								dVdt_coag_term_3 = dVdt_coag_term_3 + beta(v(i),v(j))*N(i)*N(j)*frac(i,j,k)*(v(k))
							end if
						end do
					end do

					dVdt_coag(k) = dVdt_coag_term_2 + dVdt_coag_term_3
				end if
			end do
		end if

        !!!!!!!!!!!!!!!!!!!!!!!!!
        !!!!!!!!!!!!!!!!!!!!!!!!!
        !!!!!!!!!!!!!!!!!!!!!!!!!

        do k = 1, N_modes
            YDOT((2*k-1)) =  dNdt_coag(k) + dNdt_nucl(k)
            YDOT((2*k-0)) = dVdt_coag(k) + dVdt_nucl(k) + dVdt_cond(k)
        end do
        YDOT(NEQ) =  0 -cond_loss -dNdt_nucl(1)*v_critical/vm
        return
    end subroutine FEX
end module rhs


      subroutine modisbrdf(p1,p2,p3,mu,np,rm,rp,
     s           brdfint)
      real p1,p2,p3
      real rts,rtv,rfi,rpha
      real cts,ctv,cfi,cpha
      real sts,stv,sfi
      real tanti,tantv
      real cost,sint,tvar
      real rossthick,rosselt,lispars
      real angdist,angtemp,angover
      integer mu,np,k,j
      real rm(-mu:mu),rp(np),brdfint(-mu:mu,np)
      rts=acos(rm(0))
      pi=atan(1.)*4.
      do 1 k=1,np
      do 2 j=1,mu
      rtv=acos(rm(j))
      if (j.eq.mu) then
         rfi=rm(-mu)
         else
         rfi=rp(k)+rm(-mu)
         endif
      rfi=abs(rfi)
      cts=cos(rts)
      ctv=cos(rtv)
      sts=sin(rts)
      stv=sin(rtv)
      cfi=cos(rfi)
      sfi=sin(rfi)
      cpha=cts*ctv+sts*stv*cfi
      rpha=acos(cpha)

      rosselt=(pi/2-rpha)*cpha+sin(rpha)
      rossthick=(rosselt/(cts+ctv))-pi/4.

      tanti=tan(rts)
      tantv=tan(rtv)

      angdist=tanti*tanti+tantv*tantv-2.*tanti*tantv*cfi
      angdist=sqrt(angdist)

      angtemp=1./cts+1./ctv
      cost=2.*sqrt(angdist*angdist+tanti*tanti*tantv
     &             *tantv*sfi*sfi)
      cost=cost/angtemp
      if (cost.ge.1.) cost=1.
      if (cost.le.-1.) cost=-1.
      tvar=acos(cost)
      sint=sqrt(1.-cost*cost)
      angover=(tvar-sint*cost)*angtemp/pi
      lispars=angover-angtemp+0.5*(1.+cpha)/cts/ctv

      brdfint(j,k)=p1+p2*rossthick+p3*lispars
  2   continue
  1   continue
      return
      end


      subroutine surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
     *  nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
c given the set of data points (x(i),y(i),z(i)) and the set of positive
c numbers w(i),i=1,...,m, subroutine surfit determines a smooth bivar-
c iate spline approximation s(x,y) of degrees kx and ky on the rect-
c angle xb <= x <= xe, yb <= y <= ye.
c if iopt = -1 surfit calculates the weighted least-squares spline
c according to a given set of knots.
c if iopt >= 0 the total numbers nx and ny of these knots and their
c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic-
c ally by the routine. the smoothness of s(x,y) is then achieved by
c minimalizing the discontinuity jumps in the derivatives of s(x,y)
c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1).
c the amounth of smoothness is determined by the condition that f(p) =
c sum ((w(i)*(z(i)-s(x(i),y(i))))**2) be <= s, with s a given non-neg-
c ative constant, called the smoothing factor.
c the fit is given in the b-spline representation (b-spline coefficients
c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval-
c uated by means of subroutine bispev.
c
c calling sequence:
c     call surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
c    *  nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
c
c parameters:
c  iopt  : integer flag. on entry iopt must specify whether a weighted
c          least-squares spline (iopt=-1) or a smoothing spline (iopt=0
c          or 1) must be determined.
c          if iopt=0 the routine will start with an initial set of knots
c          tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i=
c          1,...,ky+1. if iopt=1 the routine will continue with the set
c          of knots found at the last call of the routine.
c          attention: a call with iopt=1 must always be immediately pre-
c                     ceded by another call with iopt=1 or iopt=0.
c          unchanged on exit.
c  m     : integer. on entry m must specify the number of data points.
c          m >= (kx+1)*(ky+1). unchanged on exit.
c  x     : real array of dimension at least (m).
c  y     : real array of dimension at least (m).
c  z     : real array of dimension at least (m).
c          before entry, x(i),y(i),z(i) must be set to the co-ordinates
c          of the i-th data point, for i=1,...,m. the order of the data
c          points is immaterial. unchanged on exit.
c  w     : real array of dimension at least (m). before entry, w(i) must
c          be set to the i-th value in the set of weights. the w(i) must
c          be strictly positive. unchanged on exit.
c  xb,xe : real values. on entry xb,xe,yb and ye must specify the bound-
c  yb,ye   aries of the rectangular approximation domain.
c          xb<=x(i)<=xe,yb<=y(i)<=ye,i=1,...,m. unchanged on exit.
c  kx,ky : integer values. on entry kx and ky must specify the degrees
c          of the spline. 1<=kx,ky<=5. it is recommended to use bicubic
c          (kx=ky=3) splines. unchanged on exit.
c  s     : real. on entry (in case iopt>=0) s must specify the smoothing
c          factor. s >=0. unchanged on exit.
c          for advice on the choice of s see further comments
c  nxest : integer. unchanged on exit.
c  nyest : integer. unchanged on exit.
c          on entry, nxest and nyest must specify an upper bound for the
c          number of knots required in the x- and y-directions respect.
c          these numbers will also determine the storage space needed by
c          the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1).
c          in most practical situation nxest = kx+1+sqrt(m/2), nyest =
c          ky+1+sqrt(m/2) will be sufficient. see also further comments.
c  nmax  : integer. on entry nmax must specify the actual dimension of
c          the arrays tx and ty. nmax >= nxest, nmax >=nyest.
c          unchanged on exit.
c  eps   : real.
c          on entry, eps must specify a threshold for determining the
c          effective rank of an over-determined linear system of equat-
c          ions. 0 < eps < 1.  if the number of decimal digits in the
c          computer representation of a real number is q, then 10**(-q)
c          is a suitable value for eps in most practical applications.
c          unchanged on exit.
c  nx    : integer.
c          unless ier=10 (in case iopt >=0), nx will contain the total
c          number of knots with respect to the x-variable, of the spline
c          approximation returned. if the computation mode iopt=1 is
c          used, the value of nx should be left unchanged between sub-
c          sequent calls.
c          in case iopt=-1, the value of nx should be specified on entry
c  tx    : real array of dimension nmax.
c          on succesful exit, this array will contain the knots of the
c          spline with respect to the x-variable, i.e. the position of
c          the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the
c          position of the additional knots tx(1)=...=tx(kx+1)=xb and
c          tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat.
c          if the computation mode iopt=1 is used, the values of tx(1),
c          ...,tx(nx) should be left unchanged between subsequent calls.
c          if the computation mode iopt=-1 is used, the values tx(kx+2),
c          ...tx(nx-kx-1) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  ny    : integer.
c          unless ier=10 (in case iopt >=0), ny will contain the total
c          number of knots with respect to the y-variable, of the spline
c          approximation returned. if the computation mode iopt=1 is
c          used, the value of ny should be left unchanged between sub-
c          sequent calls.
c          in case iopt=-1, the value of ny should be specified on entry
c  ty    : real array of dimension nmax.
c          on succesful exit, this array will contain the knots of the
c          spline with respect to the y-variable, i.e. the position of
c          the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the
c          position of the additional knots ty(1)=...=ty(ky+1)=yb and
c          ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat.
c          if the computation mode iopt=1 is used, the values of ty(1),
c          ...,ty(ny) should be left unchanged between subsequent calls.
c          if the computation mode iopt=-1 is used, the values ty(ky+2),
c          ...ty(ny-ky-1) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  c     : real array of dimension at least (nxest-kx-1)*(nyest-ky-1).
c          on succesful exit, c contains the coefficients of the spline
c          approximation s(x,y)
c  fp    : real. unless ier=10, fp contains the weighted sum of
c          squared residuals of the spline approximation returned.
c  wrk1  : real array of dimension (lwrk1). used as workspace.
c          if the computation mode iopt=1 is used the value of wrk1(1)
c          should be left unchanged between subsequent calls.
c          on exit wrk1(2),wrk1(3),...,wrk1(1+(nx-kx-1)*(ny-ky-1)) will
c          contain the values d(i)/max(d(i)),i=1,...,(nx-kx-1)*(ny-ky-1)
c          with d(i) the i-th diagonal element of the reduced triangular
c          matrix for calculating the b-spline coefficients. it includes
c          those elements whose square is less than eps,which are treat-
c          ed as 0 in the case of presumed rank deficiency (ier<-2).
c  lwrk1 : integer. on entry lwrk1 must specify the actual dimension of
c          the array wrk1 as declared in the calling (sub)program.
c          lwrk1 must not be too small. let
c            u = nxest-kx-1, v = nyest-ky-1, km = max(kx,ky)+1,
c            ne = max(nxest,nyest), bx = kx*v+ky+1, by = ky*u+kx+1,
c            if(bx.le.by) b1 = bx, b2 = b1+v-ky
c            if(bx.gt.by) b1 = by, b2 = b1+u-kx  then
c          lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1
c  wrk2  : real array of dimension (lwrk2). used as workspace, but
c          only in the case a rank deficient system is encountered.
c  lwrk2 : integer. on entry lwrk2 must specify the actual dimension of
c          the array wrk2 as declared in the calling (sub)program.
c          lwrk2 > 0 . a save upper boundfor lwrk2 = u*v*(b2+1)+b2
c          where u,v and b2 are as above. if there are enough data
c          points, scattered uniformly over the approximation domain
c          and if the smoothing factor s is not too small, there is a
c          good chance that this extra workspace is not needed. a lot
c          of memory might therefore be saved by setting lwrk2=1.
c          (see also ier > 10)
c  iwrk  : integer array of dimension (kwrk). used as workspace.
c  kwrk  : integer. on entry kwrk must specify the actual dimension of
c          the array iwrk as declared in the calling (sub)program.
c          kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1).
c  ier   : integer. unless the routine detects an error, ier contains a
c          non-positive value on exit, i.e.
c   ier=0  : normal return. the spline returned has a residual sum of
c            squares fp such that abs(fp-s)/s <= tol with tol a relat-
c            ive tolerance set to 0.001 by the program.
c   ier=-1 : normal return. the spline returned is an interpolating
c            spline (fp=0).
c   ier=-2 : normal return. the spline returned is the weighted least-
c            squares polynomial of degrees kx and ky. in this extreme
c            case fp gives the upper bound for the smoothing factor s.
c   ier<-2 : warning. the coefficients of the spline returned have been
c            computed as the minimal norm least-squares solution of a
c            (numerically) rank deficient system. (-ier) gives the rank.
c            especially if the rank deficiency which can be computed as
c            (nx-kx-1)*(ny-ky-1)+ier, is large the results may be inac-
c            curate. they could also seriously depend on the value of
c            eps.
c   ier=1  : error. the required storage space exceeds the available
c            storage space, as specified by the parameters nxest and
c            nyest.
c            probably causes : nxest or nyest too small. if these param-
c            eters are already large, it may also indicate that s is
c            too small
c            the approximation returned is the weighted least-squares
c            spline according to the current set of knots.
c            the parameter fp gives the corresponding weighted sum of
c            squared residuals (fp>s).
c   ier=2  : error. a theoretically impossible result was found during
c            the iteration proces for finding a smoothing spline with
c            fp = s. probably causes : s too small or badly chosen eps.
c            there is an approximation returned but the corresponding
c            weighted sum of squared residuals does not satisfy the
c            condition abs(fp-s)/s < tol.
c   ier=3  : error. the maximal number of iterations maxit (set to 20
c            by the program) allowed for finding a smoothing spline
c            with fp=s has been reached. probably causes : s too small
c            there is an approximation returned but the corresponding
c            weighted sum of squared residuals does not satisfy the
c            condition abs(fp-s)/s < tol.
c   ier=4  : error. no more knots can be added because the number of
c            b-spline coefficients (nx-kx-1)*(ny-ky-1) already exceeds
c            the number of data points m.
c            probably causes : either s or m too small.
c            the approximation returned is the weighted least-squares
c            spline according to the current set of knots.
c            the parameter fp gives the corresponding weighted sum of
c            squared residuals (fp>s).
c   ier=5  : error. no more knots can be added because the additional
c            knot would (quasi) coincide with an old one.
c            probably causes : s too small or too large a weight to an
c            inaccurate data point.
c            the approximation returned is the weighted least-squares
c            spline according to the current set of knots.
c            the parameter fp gives the corresponding weighted sum of
c            squared residuals (fp>s).
c   ier=10 : error. on entry, the input data are controlled on validity
c            the following restrictions must be satisfied.
c            -1<=iopt<=1, 1<=kx,ky<=5, m>=(kx+1)*(ky+1), nxest>=2*kx+2,
c            nyest>=2*ky+2, 0<eps<1, nmax>=nxest, nmax>=nyest,
c            xb<=x(i)<=xe, yb<=y(i)<=ye, w(i)>0, i=1,...,m
c            lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1
c            kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1)
c            if iopt=-1: 2*kx+2<=nx<=nxest
c                        xb<tx(kx+2)<tx(kx+3)<...<tx(nx-kx-1)<xe
c                        2*ky+2<=ny<=nyest
c                        yb<ty(ky+2)<ty(ky+3)<...<ty(ny-ky-1)<ye
c            if iopt>=0: s>=0
c            if one of these conditions is found to be violated,control
c            is immediately repassed to the calling program. in that
c            case there is no approximation returned.
c   ier>10 : error. lwrk2 is too small, i.e. there is not enough work-
c            space for computing the minimal least-squares solution of
c            a rank deficient system of linear equations. ier gives the
c            requested value for lwrk2. there is no approximation re-
c            turned but, having saved the information contained in nx,
c            ny,tx,ty,wrk1, and having adjusted the value of lwrk2 and
c            the dimension of the array wrk2 accordingly, the user can
c            continue at the point the program was left, by calling
c            surfit with iopt=1.
c
c further comments:
c  by means of the parameter s, the user can control the tradeoff
c   between closeness of fit and smoothness of fit of the approximation.
c   if s is too large, the spline will be too smooth and signal will be
c   lost ; if s is too small the spline will pick up too much noise. in
c   the extreme cases the program will return an interpolating spline if
c   s=0 and the weighted least-squares polynomial (degrees kx,ky)if s is
c   very large. between these extremes, a properly chosen s will result
c   in a good compromise between closeness of fit and smoothness of fit.
c   to decide whether an approximation, corresponding to a certain s is
c   satisfactory the user is highly recommended to inspect the fits
c   graphically.
c   recommended values for s depend on the weights w(i). if these are
c   taken as 1/d(i) with d(i) an estimate of the standard deviation of
c   z(i), a good s-value should be found in the range (m-sqrt(2*m),m+
c   sqrt(2*m)). if nothing is known about the statistical error in z(i)
c   each w(i) can be set equal to one and s determined by trial and
c   error, taking account of the comments above. the best is then to
c   start with a very large value of s ( to determine the least-squares
c   polynomial and the corresponding upper bound fp0 for s) and then to
c   progressively decrease the value of s ( say by a factor 10 in the
c   beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
c   approximation shows more detail) to obtain closer fits.
c   to choose s very small is strongly discouraged. this considerably
c   increases computation time and memory requirements. it may also
c   cause rank-deficiency (ier<-2) and endager numerical stability.
c   to economize the search for a good s-value the program provides with
c   different modes of computation. at the first call of the routine, or
c   whenever he wants to restart with the initial set of knots the user
c   must set iopt=0.
c   if iopt=1 the program will continue with the set of knots found at
c   the last call of the routine. this will save a lot of computation
c   time if surfit is called repeatedly for different values of s.
c   the number of knots of the spline returned and their location will
c   depend on the value of s and on the complexity of the shape of the
c   function underlying the data. if the computation mode iopt=1
c   is used, the knots returned may also depend on the s-values at
c   previous calls (if these were smaller). therefore, if after a number
c   of trials with different s-values and iopt=1, the user can finally
c   accept a fit as satisfactory, it may be worthwhile for him to call
c   surfit once more with the selected value for s but now with iopt=0.
c   indeed, surfit may then return an approximation of the same quality
c   of fit but with fewer knots and therefore better if data reduction
c   is also an important objective for the user.
c   the number of knots may also depend on the upper bounds nxest and
c   nyest. indeed, if at a certain stage in surfit the number of knots
c   in one direction (say nx) has reached the value of its upper bound
c   (nxest), then from that moment on all subsequent knots are added
c   in the other (y) direction. this may indicate that the value of
c   nxest is too small. on the other hand, it gives the user the option
c   of limiting the number of knots the routine locates in any direction
c   for example, by setting nxest=2*kx+2 (the lowest allowable value for
c   nxest), the user can indicate that he wants an approximation which
c   is a simple polynomial of degree kx in the variable x.
c
c  other subroutines required:
c    fpback,fpbspl,fpsurf,fpdisc,fpgivs,fprank,fprati,fprota,fporde
c
c  references:
c   dierckx p. : an algorithm for surface fitting with spline functions
c                ima j. numer. anal. 1 (1981) 267-283.
c   dierckx p. : an algorithm for surface fitting with spline functions
c                report tw50, dept. computer science,k.u.leuven, 1980.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author:
c    p.dierckx
c    dept. computer science, k.u. leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : may 1979
c  latest update : march 1987
c
c  ..
c  ..scalar arguments..
      real*8 xb,xe,yb,ye,s,eps,fp
      integer iopt,m,kx,ky,nxest,nyest,nmax,nx,ny,lwrk1,lwrk2,kwrk,ier
c  ..array arguments..
      real*8 x(m),y(m),z(m),w(m),tx(nmax),ty(nmax),
     * c((nxest-kx-1)*(nyest-ky-1)),wrk1(lwrk1),wrk2(lwrk2)
      integer iwrk(kwrk)
c  ..local scalars..
      real*8 tol
      integer i,ib1,ib3,jb1,ki,kmax,km1,km2,kn,kwest,kx1,ky1,la,lbx,
     * lby,lco,lf,lff,lfp,lh,lq,lsx,lsy,lwest,maxit,ncest,nest,nek,
     * nminx,nminy,nmx,nmy,nreg,nrint,nxk,nyk
c  ..function references..
      integer max0
c  ..subroutine references..
c    fpsurf
c  ..
c  we set up the parameters tol and maxit.
      maxit = 20
      tol = 0.1e-02
c  before starting computations a data check is made. if the input data
c  are invalid,control is immediately repassed to the calling program.
      ier = 10
      if(eps.le.0. .or. eps.ge.1.) go to 71
      if(kx.le.0 .or. kx.gt.5) go to 71
      kx1 = kx+1
      if(ky.le.0 .or. ky.gt.5) go to 71
      ky1 = ky+1
      kmax = max0(kx,ky)
      km1 = kmax+1
      km2 = km1+1
      if(iopt.lt.(-1) .or. iopt.gt.1) go to 71
      if(m.lt.(kx1*ky1)) go to 71
      nminx = 2*kx1
      if(nxest.lt.nminx .or. nxest.gt.nmax) go to 71
      nminy = 2*ky1
      if(nyest.lt.nminy .or. nyest.gt.nmax) go to 71
      nest = max0(nxest,nyest)
      nxk = nxest-kx1
      nyk = nyest-ky1
      ncest = nxk*nyk
      nmx = nxest-nminx+1
      nmy = nyest-nminy+1
      nrint = nmx+nmy
      nreg = nmx*nmy
      ib1 = kx*nyk+ky1
      jb1 = ky*nxk+kx1
      ib3 = kx1*nyk+1
      if(ib1.le.jb1) go to 10
      ib1 = jb1
      ib3 = ky1*nxk+1
  10  lwest = ncest*(2+ib1+ib3)+2*(nrint+nest*km2+m*km1)+ib3
      kwest = m+nreg
      if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 71
      if(xb.ge.xe .or. yb.ge.ye) go to 71
      do 20 i=1,m
        if(w(i).le.0.) go to 70
        if(x(i).lt.xb .or. x(i).gt.xe) go to 71
        if(y(i).lt.yb .or. y(i).gt.ye) go to 71
  20  continue
      if(iopt.ge.0) go to 50
      if(nx.lt.nminx .or. nx.gt.nxest) go to 71
      nxk = nx-kx1
      tx(kx1) = xb
      tx(nxk+1) = xe
      do 30 i=kx1,nxk
        if(tx(i+1).le.tx(i)) go to 72
  30  continue
      if(ny.lt.nminy .or. ny.gt.nyest) go to 71
      nyk = ny-ky1
      ty(ky1) = yb
      ty(nyk+1) = ye
      do 40 i=ky1,nyk
        if(ty(i+1).le.ty(i)) go to 73
  40  continue
      go to 60
  50  if(s.lt.0.) go to 71
  60  ier = 0
c  we partition the working space and determine the spline approximation
      kn = 1
      ki = kn+m
      lq = 2
      la = lq+ncest*ib3
      lf = la+ncest*ib1
      lff = lf+ncest
      lfp = lff+ncest
      lco = lfp+nrint
      lh = lco+nrint
      lbx = lh+ib3
      nek = nest*km2
      lby = lbx+nek
      lsx = lby+nek
      lsy = lsx+m*km1
      call fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
     * eps,tol,maxit,nest,km1,km2,ib1,ib3,ncest,nrint,nreg,nx,tx,
     * ny,ty,c,fp,wrk1(1),wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff),
     * wrk1(la),wrk1(lq),wrk1(lbx),wrk1(lby),wrk1(lsx),wrk1(lsy),
     * wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier)
 70   return
 71   print*,"iopt,kx,ky,m=",iopt,kx,ky,m
      print*,"nxest,nyest,nmax=",nxest,nyest,nmax
      print*,"lwrk1,lwrk2,kwrk=",lwrk1,lwrk2,kwrk
      print*,"xb,xe,yb,ye=",xb,xe,yb,ye
      print*,"eps,s",eps,s
      return
 72   print*,"tx=",tx
      return
 73   print*,"ty=",ty
      return
      end


C FILE: CALLBACK.F
      SUBROUTINE FOO(FUN,R)
      EXTERNAL FUN
      INTEGER I
      REAL*8 R, FUN
Cf2py intent(out) r
      R = 0D0
      DO I=-5,5
         R = R + FUN(I)
      ENDDO
      END
C END OF FILE CALLBACK.F


MODULE FUN_Loop
!!#### PURPOSE
!! Allows an Integer to be "looped" over a range from.
!
!!                 I = Loop( I , N )
!
!! Increments I from 1:N, and Loop( 0 , N ) = 1, always.

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### Loop PROCEDURE OVERLOADING
INTERFACE Loop
 MODULE PROCEDURE Loop_I1
 MODULE PROCEDURE Loop_I2
 MODULE PROCEDURE Loop_I4
 MODULE PROCEDURE Loop_I8
END INTERFACE

!!#### ACCESS
PUBLIC :: Loop

CONTAINS

FUNCTION Loop_I1( I , N , COUNTER ) RESULT(J)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1 !!((01-A-KND_IntrinsicTypes.f90))
INTEGER(KIND_I),INTENT(IN) :: I,N
INTEGER(KIND_I),OPTIONAL,INTENT(INOUT) :: COUNTER
INTEGER(KIND_I) :: J
J = MOD(I,N)+1_KIND_I
IF( PRESENT(COUNTER) )COUNTER = COUNTER + 1
END FUNCTION

FUNCTION Loop_I2( I , N , COUNTER ) RESULT(J)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2 !!((01-A-KND_IntrinsicTypes.f90))
INTEGER(KIND_I),INTENT(IN) :: I,N
INTEGER(KIND_I),OPTIONAL,INTENT(INOUT) :: COUNTER
INTEGER(KIND_I) :: J
J = MOD(I,N)+1_KIND_I
IF( PRESENT(COUNTER) )COUNTER = COUNTER + 1
END FUNCTION

FUNCTION Loop_I4( I , N , COUNTER ) RESULT(J)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4 !!((01-A-KND_IntrinsicTypes.f90))
INTEGER(KIND_I),INTENT(IN) :: I,N
INTEGER(KIND_I),OPTIONAL,INTENT(INOUT) :: COUNTER
INTEGER(KIND_I) :: J
J = MOD(I,N)+1_KIND_I
IF( PRESENT(COUNTER) )COUNTER = COUNTER + 1
END FUNCTION

FUNCTION Loop_I8( I , N , COUNTER ) RESULT(J)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8 !!((01-A-KND_IntrinsicTypes.f90))
INTEGER(KIND_I),INTENT(IN) :: I,N
INTEGER(KIND_I),OPTIONAL,INTENT(INOUT) :: COUNTER
INTEGER(KIND_I) :: J
J = MOD(I,N)+1_KIND_I
IF( PRESENT(COUNTER) )COUNTER = COUNTER + 1
END FUNCTION

END MODULE