      subroutine SPRPL(Y,SYMBOL,IMAGE,NCHAR,Y1,Y2,RESET)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C
c>> 1997-05-24 DPRRL Krogh  Changes to use .C. and C%%.
C>> 1996-01-19 SPRPL Krogh  Changes to automate conversion to C.
C>> 1994-10-20 SPRPL Krogh  Changes to use M77CON
C>> 1994-08-05 SPRPL CLL Use C = 1.5001 instead of 1.5
C>> 1992-05-12 CLL Avoid use of sign function.
C>> 1990-10-10 WV Snyder JPL Don't overflow in test for zero in interval
C>> 1988-06-24 CLL
C     ------------------------------------------------------------------
C     SUBROUTINE ARGUMENTS
C     --------------------
C     Y         Data values to be plotted.
C
C     SYMBOL    Single character to be used as plot
C               symbol.
C
C     IMAGE     Character variables in which plot image is
C               to be constructed.
C
C     NCHAR     Number of character positions in the
C               array IMAGE() to be used as a plot
C               symbol.
C
C     Y1,Y2     Numbers that bracket the range of
C               values of Y to be plotted in IMAGE().
C
C     RESET     Flag to reset the line image.If RESET
C               = .TRUE. the subroutine will:
C               1) Store NCHAR blank characters into
C                  IMAGE().
C               2) Store the character '0' in the zero
C                  value position if zero is contained
C                  in the interval [ZMIN,ZMAX].
C               3) Store the character specified by
C                  SYMBOL in the Y value position.
C
C               If RESET = .FALSE. the subroutine will
C               only execute Step 3 above.
C
C     ------------------------------------------------------
C
C     1969 July 9,programmed by C.L.Lawson,JPL
C     1981 change Hollerith characters to Fortran 77
C          characters,K.Stewart,JPL
C     1983 coded for Fortran 77,C.L.Lawson,S.Chan,JPL
C     1988-06-24 CLL Made DP version.
c     1992-05-12 CLL Noted that '0' was not being placed in IMAGE in
c       some cases when it should have on VAX and Unisys.  Was due to
c       branching on the sign of ZMIN which could be zero.  Changed
c       code to avoid use of the sign function.
C     1994-08-05 CLL Use C = 1.5001 instead of 1.5 to improve
c       consistency of symbol placement on different computers.
C     ------------------------------------------------------------------
c--S replaces "?": ?PRPL
C     ------------------------------------------------------------------
      logical RESET
      integer JY, JZ, NCHAR
      real             A, B, C, DZ, FJZ, FNC, HALF, ONE, Y, Y1, Y2
      real             ZERO, ZMAX, ZMIN
      character        IMAGE*(*), SYMBOL
      parameter(HALF = 0.5E0, ONE = 1.0E0, ZERO = 0.0E0)
C     ------------------------------------------------------------------
      ZMIN= min(Y1,Y2)
      ZMAX= max(Y1,Y2)
      DZ=ZMAX-ZMIN
C
C     Change ZMIN,ZMAX to avoid DZ=0
C
      if (DZ .EQ. ZERO) then
        if (ZMIN .EQ. ZERO) then
          ZMIN= -ONE
          ZMAX= +ONE
        else
          ZMIN= 0.9E0 * ZMIN
          ZMAX= 1.1E0 * ZMAX
        endif
          DZ=ZMAX-ZMIN
      endif
C
      FNC= real(NCHAR)
C
C     Compute A,B,C to define linear transformation
C
      A=ZMIN
      B=(FNC - ONE)/DZ
      C= 1.5001E0
C
C     Set JZ = index of zero using the current A, B, C.
c     if this JZ is in the plotting range, exclusive of the end points,
c     i.e., if 1 .lt. JZ .lt. NCHAR, then recompute A,B,C to make zero
c     fall in the center of its descretization interval.  This will
c     cause data values that are symmetric around zero to plot at
c     locations that are symmetric around the zero location.
C
        JZ = -A * B + C
        if (JZ .gt. 1 .and. JZ .lt. NCHAR) then
          FJZ = real(JZ)
          A = ZERO
          C = FJZ + HALF
          B = min( (FNC-FJZ)/ZMAX, (ONE - FJZ)/ZMIN )
        endif
C
C     End..compute A,B,C,JZ
C
      if (RESET) then
C%%      for(jy = 0; jy <= nchar-1; jy++)  image[jy] = ' ';
C%%         image[nchar] = '\0';
        if (NCHAR .ne. 0) IMAGE(1:NCHAR)= ' '
        if (JZ .ge. 1 .and. JZ .le. NCHAR) IMAGE(JZ:JZ)= '0'
      endif
C
C     Process Y
C
      JY=(Y-A) * B + C
      if (JY .gt. 0) then
        if (JY .le. NCHAR) then
          IMAGE(JY:JY)=SYMBOL
        else if (NCHAR .ge. 3) then
C%%       image[nchar-3]='O'; image[nchar-2]='U'; image[nchar-1]='T';
          IMAGE(NCHAR-2:NCHAR)='OUT'
        endif
      else if (NCHAR .ge. 3) then
C%%       image[0]='O'; image[1]='U'; image[2]='T';
        IMAGE(1:3)='OUT'
      endif
      end


      PROGRAM LA_SGGLSE_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GGLSE, LA_LANGE
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" .
      REAL(WP) ::  R1
      INTEGER :: I, J, INFO, M, N, P
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), C(:), D(:), X(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GGLSE Example Program Results'
      M=5; N = 3; P = 2
      ALLOCATE( A(M,N), B(P,N), C(M), D(P), X(N) )

      OPEN(UNIT=21,FILE='gglse.ma',STATUS='UNKNOWN')
      DO I=1,M
         DO J=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      OPEN(UNIT=22,FILE='gglse.mb',STATUS='UNKNOWN')
      DO I=1,P
         DO J=1,N
            READ(22,*) B(I,J)
         ENDDO
      ENDDO
      CLOSE(22)

      OPEN(UNIT=23,FILE='gglse.mc',STATUS='UNKNOWN')
      DO I=1,M
         READ(23,*) C(I)
      ENDDO
      CLOSE(23)

      OPEN(UNIT=24,FILE='gglse.md',STATUS='UNKNOWN')
      DO I=1,P
         READ(24,*) D(I)
      ENDDO
      CLOSE(24)

      WRITE(*,*)'Matrix A :'
      DO I=1,M;
         WRITE(*,"(3(F9.5))") A(I,:);
      ENDDO

      WRITE(*,*)'Matrix B : '
      DO I=1,P;
         WRITE(*,"(3(F9.5))") B(I,:);
      ENDDO

      WRITE(*,*)'Vector C : '
      DO I=1,M;
         WRITE(*,"(F9.5)") C(I);
      ENDDO

      WRITE(*,*) 'Vector D : '
      DO I=1,P;
         WRITE(*,"(F9.5))") D(I);
      ENDDO
      WRITE(*,*)
      WRITE(*,*) 'CALL LA_GGLSE( A, B, C, D, X, INFO )'
      CALL LA_GGLSE( A, B, C, D, X, INFO )

      WRITE(*,*) 'C on exit : '
      DO I=1,M;
         WRITE(*,"(E14.6)") C(I);
      ENDDO

      WRITE(*,*) 'X on exit : '
      DO I=1,N;
         WRITE(*,"(E14.5)") X(I);
      ENDDO

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

      R1=LA_LANGE(C(N-P+1:M),'F')
      WRITE(*,*)'The residual r = ',R1

      END PROGRAM LA_SGGLSE_EXAMPLE


!=======================================================================
! Created by
!     Keurfon Luu <keurfon.luu@mines-paristech.fr>
!     MINES ParisTech - Centre de Géosciences
!     PSL - Research University
!=======================================================================

module fteik3d

  use omp_lib

  implicit none

  integer(kind = 4), parameter :: scheme = 1
  real(kind = 8), parameter :: zerr = 1.d-4
  real(kind = 8), parameter :: Big = 99999.d0

contains

  subroutine solver3d(slow, tt, nz, nx, ny, zsrc, xsrc, ysrc, dz, dx, dy, n_sweep, ttgrad)
    real(kind = 8), dimension(nz,nx,ny), intent(in) :: slow
    real(kind = 8), dimension(nz,nx,ny), intent(out) :: tt
    real(kind = 8), dimension(3,nz,nx,ny), intent(out), optional :: ttgrad
    integer(kind = 4), intent(in) :: nz, nx, ny, n_sweep
    real(kind = 8), intent(in) :: zsrc, xsrc, ysrc, dz, dx, dy

    integer(kind = 4) :: i, j, k, kk, iflag
    integer(kind = 4) :: zsi, xsi, ysi
    integer(kind = 4) :: sgntz, sgntx, sgnty, sgnvz, sgnvx, sgnvy

    real(kind = 8) :: ttz(nz,nx,ny), ttx(nz,nx,ny), tty(nz,nx,ny)
    real(kind = 8) :: zsa, xsa, ysa
    real(kind = 8) :: tzc, txc, tyc
    real(kind = 8) :: vzero

    ! Check inputs
    if ( nz .lt. 3 .or. nx .lt. 3 .or. ny .lt. 3 ) stop "Error: grid size nz, nx, ny too small"
    if ( dz .le. 0.d0 .or. dx .le. 0.d0 .or. dy .le. 0.d0 ) stop "Error: grid spacing dz, dx, dy too small"
    if ( n_sweep .lt. 0 ) stop "Error: wrong sweep number"
    if ( minval(slow) .le. 0.d0 .or. maxval(slow) .ge. 1.d0 ) stop "Error: slownesses are strange"
    if ( zsrc .lt. 0.d0 .or. zsrc .gt. dfloat(nz-1) * dz &
         .or. xsrc .lt. 0.d0 .or. xsrc .gt. dfloat(nx-1) * dx &
         .or. ysrc .lt. 0.d0 .or. ysrc .gt. dfloat(ny-1) * dy ) &
      stop "Error: source out of bounds"

    ! Convert src to grid position and try and take into account machine precision
    zsa = zsrc / dz + 1.d0
    xsa = xsrc / dx + 1.d0
    ysa = ysrc / dy + 1.d0

    ! Try to handle edges simply for source due to precision
    if ( zsa .ge. dfloat(nz) ) zsa = zsa - zerr
    if ( xsa .ge. dfloat(nx) ) xsa = xsa - zerr
    if ( ysa .ge. dfloat(ny) ) ysa = ysa - zerr

    ! Grid points to initialize source
    zsi = int(zsa)
    xsi = int(xsa)
    ysi = int(ysa)
    vzero = slow(zsi,xsi,ysi)

    ! Allocate work array for traveltimes
    tt = Big
    if ( present(ttgrad) ) then
      ttz = 0.d0
      ttx = 0.d0
      tty = 0.d0
    end if

    ! Initialize points around source
    tt(zsi,xsi,ysi) = t_ana(zsi, xsi, ysi, dz, dx, dy, zsa, xsa, ysa, vzero)
    tt(zsi+1,xsi,ysi) = t_ana(zsi+1, xsi, ysi, dz, dx, dy, zsa, xsa, ysa, vzero)
    tt(zsi,xsi+1,ysi) = t_ana(zsi, xsi+1, ysi, dz, dx, dy, zsa, xsa, ysa, vzero)
    tt(zsi,xsi,ysi+1) = t_ana(zsi, xsi, ysi+1, dz, dx, dy, zsa, xsa, ysa, vzero)
    tt(zsi+1,xsi+1,ysi) = t_ana(zsi+1, xsi+1, ysi, dz, dx, dy, zsa, xsa, ysa, vzero)
    tt(zsi+1,xsi,ysi+1) = t_ana(zsi+1, xsi, ysi+1, dz, dx, dy, zsa, xsa, ysa, vzero)
    tt(zsi,xsi+1,ysi+1) = t_ana(zsi, xsi+1, ysi+1, dz, dx, dy, zsa, xsa, ysa, vzero)
    tt(zsi+1,xsi+1,ysi+1) = t_ana(zsi+1, xsi+1, ysi+1, dz, dx, dy, zsa, xsa, ysa, vzero)

    ! Full sweeps
    do kk = 1, n_sweep
      call sweep3d(scheme, slow, tt, ttz, ttx, tty, nz, nx, ny, dz, dx, dy, &
                   zsi, xsi, ysi, tzc, txc, tyc, zsa, xsa, ysa, vzero)
    end do

    if ( present(ttgrad) ) then
      ttgrad(1,:,:,:) = ttz
      ttgrad(2,:,:,:) = ttx
      ttgrad(3,:,:,:) = tty
    end if
    return
  contains

    ! Function to calculate analytical times in homogeneous model
    real(kind = 8) function t_ana(i, j, k, dz, dx, dy, zsa, xsa, ysa, vzero)
      integer(kind = 4), intent(in) :: i, j, k
      real(kind = 8), intent(in) :: dz, dx, dy, zsa, xsa, ysa, vzero

      t_ana = vzero * ( ( ( dfloat(i) - zsa ) * dz )**2.d0 &
                      + ( ( dfloat(j) - xsa ) * dx )**2.d0 &
                      + ( ( dfloat(k) - ysa ) * dy )**2.d0 )**0.5d0
      return
    end function t_ana

    ! Function to calculate analytical times in homogeneous model + derivatives of times
    real(kind = 8) function t_anad(tzc, txc, tyc, i, j, k, dz, dx, dy, zsa, xsa, ysa, vzero)
      integer(kind = 4), intent(in) :: i, j, k
      real(kind = 8), intent(in) :: dz, dx, dy, zsa, xsa, ysa, vzero
      real(kind = 8) :: d0
      real(kind = 8), intent(out) :: tzc, txc, tyc

      d0 = ( ( dfloat(i) - zsa ) * dz )**2.d0 &
           + ( ( dfloat(j) - xsa ) * dx )**2.d0 &
           + ( ( dfloat(k) - ysa ) * dy )**2.d0
      t_anad = vzero * (d0**0.5d0)
      if ( d0 .gt. 0.d0 ) then
        tzc = ( d0**(-0.5d0) ) * ( dfloat(i) - zsa ) * dz * vzero
        txc = ( d0**(-0.5d0) ) * ( dfloat(j) - xsa ) * dx * vzero
        tyc = ( d0**(-0.5d0) ) * ( dfloat(k) - ysa ) * dy * vzero
      else
        tzc = 0.d0
        txc = 0.d0
        tyc = 0.d0
      end if
      return
    end function t_anad

    ! Function to perform sweep
    subroutine sweep3d(scheme, slow, tt, ttz, ttx, tty, nz, nx, ny, dz, dx, dy, &
                       zsi, xsi, ysi, tzc, txc, tyc, zsa, xsa, ysa, vzero)
      real(kind = 8), intent(in) :: slow(nz,nx,ny)
      real(kind = 8), intent(inout) :: tt(nz,nx,ny), ttz(nz,nx,ny), ttx(nz,nx,ny), tty(nz,nx,ny)
      integer(kind = 4), intent(in) :: scheme, nz, nx, ny, zsi, xsi, ysi
      real(kind = 8), intent(in) :: dz, dx, dy, zsa, xsa, ysa, vzero
      real(kind = 8), intent(inout) :: tzc, txc, tyc
      integer(kind = 4) :: i, j, k, sgntz, sgntx, sgnty, sgnvz, sgnvx, sgnvy
      integer(kind = 4) :: i1, j1, k1, imin
      real(kind = 8) :: dzi, dxi, dyi, dz2i, dx2i, dy2i, dz2dx2, dz2dy2, dx2dy2, dsum
      real(kind = 8) :: vref, time_sol(8)
      real(kind = 8) :: tv, te, tn, ten, tnv, tev, tnve
      real(kind = 8) :: t1d, t2d, t3d, t1, t2, t3, ta, tb, tc
      real(kind = 8) :: t1d1, t1d2, t1d3, t2d1, t2d2, t2d3
      real(kind = 8) :: apoly, bpoly, cpoly, dpoly

      ! Precalculate constants
      dzi = 1.d0 / dz
      dxi = 1.d0 / dx
      dyi = 1.d0 / dy
      dz2i = 1.d0 / (dz*dz)
      dx2i = 1.d0 / (dx*dx)
      dy2i = 1.d0 / (dy*dy)
      dz2dx2 = dz2i * dx2i
      dz2dy2 = dz2i * dy2i
      dx2dy2 = dx2i * dy2i
      dsum = dz2i + dx2i + dy2i

      select case(scheme)
      ! Standard sweeping scheme
      case(1)
        ! First sweeping: Top->Bottom ; West->East ; South->North
        sgntz = 1 ; sgntx = 1 ; sgnty = 1
        sgnvz = 1 ; sgnvx = 1 ; sgnvy = 1
        do k = 2, ny
          do j = 2, nx
            do i = 2, nz
              include "Include_FTeik3d.f"
            end do
          end do
        end do

        ! Second sweeping: Top->Bottom ; East->West ; South->North
        sgntz = 1 ; sgntx = -1 ; sgnty = 1
        sgnvz = 1 ; sgnvx = 0 ; sgnvy = 1
        do k = 2, ny
          do j = nx-1, 1, -1
            do i = 2, nz
              include "Include_FTeik3d.f"
            end do
          end do
        end do

        ! Third sweeping: Top->Bottom ; West->East ; North->South
        sgntz = 1 ; sgntx = 1 ; sgnty = -1
        sgnvz = 1 ; sgnvx = 1 ; sgnvy = 0
        do k = ny-1, 1, -1
          do j = 2, nx
            do i = 2, nz
              include "Include_FTeik3d.f"
            end do
          end do
        end do

        ! Fouth sweeping: Top->Bottom ; East->West ; North->South
        sgntz = 1 ; sgntx = -1 ; sgnty = -1
        sgnvz = 1 ; sgnvx = 0 ; sgnvy = 0
        do k = ny-1, 1, -1
          do j = nx-1, 1, -1
            do i = 2, nz
              include "Include_FTeik3d.f"
            end do
          end do
        end do

        ! Fifth sweeping: Bottom->Top ; West->East ; South->North
        sgntz = -1 ; sgntx = 1 ; sgnty = 1
        sgnvz = 0 ; sgnvx = 1 ; sgnvy = 1
        do k = 2, ny
          do j = 2, nx
            do i = nz-1, 1, -1
              include "Include_FTeik3d.f"
            end do
          end do
        end do

        ! Sixth sweeping: Bottom->Top ; East->West ; South->North
        sgntz = -1 ; sgntx = -1 ; sgnty = 1
        sgnvz = 0 ; sgnvx = 0 ; sgnvy = 1
        do k = 2, ny
          do j = nx-1, 1, -1
            do i = nz-1, 1, -1
              include "Include_FTeik3d.f"
            end do
          end do
        end do

        ! Seventh sweeping: Bottom->Top ; West->East ; North->South
        sgntz = -1 ; sgntx = 1 ; sgnty = -1
        sgnvz = 0 ; sgnvx = 1 ; sgnvy = 0
        do k = ny-1, 1, -1
          do j = 2, nx
            do i = nz-1, 1, -1
              include "Include_FTeik3d.f"
            end do
          end do
        end do

        ! Eighth sweeping: Bottom->Top ; East->West ; North->South
        sgntz = -1 ; sgntx = -1 ; sgnty = -1
        sgnvz = 0 ; sgnvx = 0 ; sgnvy = 0
        do k = ny-1, 1, -1
          do j = nx-1, 1, -1
            do i = nz-1, 1, -1
              include "Include_FTeik3d.f"
            end do
          end do
        end do
      end select
      return
    end subroutine sweep3d

  end subroutine solver3d

  subroutine solve(slow, tt, nz, nx, ny, zs, xs, ys, dz, dx, dy, n_sweep, nsrc, n_threads)
    integer(kind = 4), intent(in) :: nz, nx, ny, nsrc, n_sweep
    integer(kind = 4), intent(in), optional :: n_threads
    real(kind = 8), intent(in) :: slow(nz,nx,ny), zs(nsrc), xs(nsrc), ys(nsrc), dz, dx, dy
    real(kind = 8), intent(out) :: tt(nsrc,nz,nx,ny)
    integer(kind = 4) :: k

    if ( present(n_threads) ) call omp_set_num_threads(n_threads)

    !$omp parallel default(shared)
    !$omp do schedule(runtime)
    do k = 1, nsrc
      call solver3d(slow, tt(k,:,:,:), nz, nx, ny, zs(k), xs(k), ys(k), dz, dx, dy, n_sweep)
    end do
    !$omp end parallel
    return
  end subroutine solve

  function interp3(x, y, z, v, xq, yq, zq) result(vq)
    real(kind = 8) :: vq
    real(kind = 8), intent(in) :: xq, yq, zq
    real(kind = 8), dimension(:), intent(in) :: x, y, z
    real(kind = 8), dimension(:,:,:), intent(in) :: v
    integer(kind = 4) :: nx, ny, nz, i1, i2, j1, j2, k1, k2
    real(kind = 8) :: x1, x2, y1, y2, z1, z2, v111, v211, v121, v221, &
      v112, v212, v122, v222
    real(kind = 8) :: N(8), ax(8), ay(8), az(8), av(8)

    nx = size(v, 1)
    ny = size(v, 2)
    nz = size(v, 3)
    i1 = minloc(xq - x, dim = 1, mask = xq .ge. x)
    j1 = minloc(yq - y, dim = 1, mask = yq .ge. y)
    k1 = minloc(zq - z, dim = 1, mask = zq .ge. z)
    i2 = i1 + 1
    j2 = j1 + 1
    k2 = k1 + 1

    if ( i1 .eq. nx .and. j1 .ne. ny .and. k1 .ne. nz ) then
      x1 = x(i1)
      x2 = 2.d0 * x1 - x(nx-1)
      y1 = y(j1)
      y2 = y(j2)
      z1 = z(k1)
      z2 = z(k2)
      v111 = v(i1,j1,k1)
      v211 = 0.d0
      v121 = v(i1,j2,k1)
      v221 = 0.d0
      v112 = v(i1,j1,k2)
      v212 = 0.d0
      v122 = v(i1,j2,k2)
      v222 = 0.d0
    else if ( i1 .ne. nx .and. j1 .eq. ny .and. k1 .ne. nz ) then
      x1 = x(i1)
      x2 = x(i2)
      y1 = y(j1)
      y2 = 2.d0 * y1 - y(ny-1)
      z1 = z(k1)
      z2 = z(k2)
      v111 = v(i1,j1,k1)
      v211 = v(i2,j1,k1)
      v121 = 0.d0
      v221 = 0.d0
      v112 = v(i1,j1,k2)
      v212 = v(i2,j1,k2)
      v122 = 0.d0
      v222 = 0.d0
    else if ( i1 .ne. nx .and. j1 .ne. ny .and. k1 .eq. nz ) then
      x1 = x(i1)
      x2 = x(i2)
      y1 = y(j1)
      y2 = y(j2)
      z1 = z(k1)
      z2 = 2.d0 * z1 - z(nz-1)
      v111 = v(i1,j1,k1)
      v211 = v(i2,j1,k1)
      v121 = v(i1,j2,k1)
      v221 = v(i2,j2,k1)
      v112 = 0.d0
      v212 = 0.d0
      v122 = 0.d0
      v222 = 0.d0
    else if ( i1 .eq. nx .and. j1 .eq. ny .and. k1 .ne. nz ) then
      x1 = x(i1)
      x2 = 2.d0 * x1 - x(nx-1)
      y1 = y(j1)
      y2 = 2.d0 * y1 - y(ny-1)
      z1 = z(k1)
      z2 = z(k2)
      v111 = v(i1,j1,k1)
      v211 = 0.d0
      v121 = 0.d0
      v221 = 0.d0
      v112 = v(i1,j1,k2)
      v212 = 0.d0
      v122 = 0.d0
      v222 = 0.d0
    else if ( i1 .eq. nx .and. j1 .ne. ny .and. k1 .eq. nz ) then
      x1 = x(i1)
      x2 = 2.d0 * x1 - x(nx-1)
      y1 = y(j1)
      y2 = y(j2)
      z1 = z(k1)
      z2 = 2.d0 * z1 - z(nz-1)
      v111 = v(i1,j1,k1)
      v211 = 0.d0
      v121 = v(i1,j2,k1)
      v221 = 0.d0
      v112 = 0.d0
      v212 = 0.d0
      v122 = 0.d0
      v222 = 0.d0
    else if ( i1 .ne. nx .and. j1 .eq. ny .and. k1 .eq. nz ) then
      x1 = x(i1)
      x2 = x(i2)
      y1 = y(j1)
      y2 = 2.d0 * y1 - y(ny-1)
      z1 = z(k1)
      z2 = 2.d0 * z1 - z(nz-1)
      v111 = v(i1,j1,k1)
      v211 = v(i2,j1,k1)
      v121 = 0.d0
      v221 = 0.d0
      v112 = 0.d0
      v212 = 0.d0
      v122 = 0.d0
      v222 = 0.d0
    else if ( i1 .eq. nx .and. j1 .eq. ny .and. k1 .eq. nz ) then
      x1 = x(i1)
      x2 = 2.d0 * x1 - x(nx-1)
      y1 = y(j1)
      y2 = 2.d0 * y1 - y(ny-1)
      z1 = z(k1)
      z2 = 2.d0 * z1 - z(nz-1)
      v111 = v(i1,j1,k1)
      v211 = 0.d0
      v121 = 0.d0
      v221 = 0.d0
      v112 = 0.d0
      v212 = 0.d0
      v122 = 0.d0
      v222 = 0.d0
    else
      x1 = x(i1)
      x2 = x(i2)
      y1 = y(j1)
      y2 = y(j2)
      z1 = z(k1)
      z2 = z(k2)
      v111 = v(i1,j1,k1)
      v211 = v(i2,j1,k1)
      v121 = v(i1,j2,k1)
      v221 = v(i2,j2,k1)
      v112 = v(i1,j1,k2)
      v212 = v(i2,j1,k2)
      v122 = v(i1,j2,k2)
      v222 = v(i2,j2,k2)
    end if

    ax = [ x2, x1, x2, x1, x2, x1, x2, x1 ]
    ay = [ y2, y2, y1, y1, y2, y2, y1, y1 ]
    az = [ z2, z2, z2, z2, z1, z1, z1, z1 ]
    av = [ v111, v211, v121, v221, v112, v212, v212, v222 ]
    N = dabs( (ax - xq) * (ay - yq) * (az - zq) ) / dabs( (x2 - x1) * (y2 - y1) * (z2 -z1) )
    vq = dot_product(av, N)
    return
  end function interp3

  ! Apparent velocity interpolation: returns NaN when query point is
  ! near source (within [zsrc-dz, zsrc], [xsrc-dx, xsrc], [ysrc-dy, ysrc])
  ! as traveltime at source is zero. Commented until fixed.
  ! function interp3(source, x, y, z, v, xq, yq, zq) result(vq)
  !   real :: vq
  !   real, intent(in) :: xq, yq, zq
  !   real, dimension(:), intent(in) :: source, x, y, z
  !   real, dimension(:,:,:), intent(in) :: v
  !   integer :: nx, ny, nz, i1, i2, j1, j2, k1, k2
  !   real :: x1, x2, y1, y2, z1, z2, v111, v211, v121, v221, &
  !     v112, v212, v122, v222, d111, d211, d121, d221, d112, d212, d122, d222
  !   real :: N(8), ax(8), ay(8), az(8), av(8), ad(8)
  !
  !   if ( all(source .eq. [ xq, yq, zq ]) ) then
  !     vq = 0.
  !   else
  !     nx = size(v, 1)
  !     ny = size(v, 2)
  !     nz = size(v, 3)
  !     i1 = minloc(xq - x, dim = 1, mask = xq .ge. x)
  !     j1 = minloc(yq - y, dim = 1, mask = yq .ge. y)
  !     k1 = minloc(zq - z, dim = 1, mask = zq .ge. z)
  !     i2 = i1 + 1
  !     j2 = j1 + 1
  !     k2 = k1 + 1
  !
  !     if ( i1 .eq. nx .and. j1 .ne. ny .and. k1 .ne. nz ) then
  !       x1 = x(i1); x2 = 2.*x1 - x(nx-1); y1 = y(j1); y2 = y(j2); z1 = z(k1); z2 = z(k2)
  !       d111 = sqrt(sum((source-[x1,y1,z1])**2)); d211 = 0.
  !       d121 = sqrt(sum((source-[x1,y2,z1])**2)); d221 = 0.
  !       d112 = sqrt(sum((source-[x1,y1,z2])**2)); d212 = 0.
  !       d122 = sqrt(sum((source-[x1,y2,z2])**2)); d222 = 0.
  !       v111 = v(i1,j1,k1); v211 = 1.; v121 = v(i1,j2,k1); v221 = 1.
  !       v112 = v(i1,j1,k2); v212 = 1.; v122 = v(i1,j2,k2); v222 = 1.
  !     else if ( i1 .ne. nx .and. j1 .eq. ny .and. k1 .ne. nz ) then
  !       x1 = x(i1); x2 = x(i2); y1 = y(j1); y2 = 2.*y1 - y(ny-1); z1 = z(k1); z2 = z(k2)
  !       d111 = sqrt(sum((source-[x1,y1,z1])**2)); d211 = sqrt(sum((source-[x2,y1,z1])**2))
  !       d121 = 0.; d221 = 0.
  !       d112 = sqrt(sum((source-[x1,y1,z2])**2)); d212 = sqrt(sum((source-[x2,y1,z2])**2))
  !       d122 = 0.; d222 = 0.
  !       v111 = v(i1,j1,k1); v211 = v(i2,j1,k1); v121 = 1.; v221 = 1.
  !       v112 = v(i1,j1,k2); v212 = v(i2,j1,k2); v122 = 1.; v222 = 1.
  !     else if ( i1 .ne. nx .and. j1 .ne. ny .and. k1 .eq. nz ) then
  !       x1 = x(i1); x2 = x(i2); y1 = y(j1); y2 = y(j2); z1 = z(k1); z2 = 2.*z1 - z(nz-1)
  !       d111 = sqrt(sum((source-[x1,y1,z1])**2)); d211 = sqrt(sum((source-[x2,y1,z1])**2))
  !       d121 = sqrt(sum((source-[x1,y2,z1])**2)); d221 = sqrt(sum((source-[x2,y2,z1])**2))
  !       d112 = 0.; d212 = 0.
  !       d122 = 0.; d222 = 0.
  !       v111 = v(i1,j1,k1); v211 = v(i2,j1,k1); v121 = v(i1,j2,k1); v221 = v(i2,j2,k1)
  !       v112 = 1.; v212 = 1.; v122 = 1.; v222 = 1.
  !     else if ( i1 .eq. nx .and. j1 .eq. ny .and. k1 .ne. nz ) then
  !       x1 = x(i1); x2 = 2.*x1 - x(nx-1); y1 = y(j1); y2 = 2.*y1 - y(ny-1); z1 = z(k1); z2 = z(k2)
  !       d111 = sqrt(sum((source-[x1,y1,z1])**2)); d211 = 0.
  !       d121 = 0.; d221 = 0.
  !       d112 = sqrt(sum((source-[x1,y1,z2])**2)); d212 = 0.
  !       d122 = 0.; d222 = 0.
  !       v111 = v(i1,j1,k1); v211 = 1.; v121 = 1.; v221 = 1.
  !       v112 = v(i1,j1,k2); v212 = 1.; v122 = 1.; v222 = 1.
  !     else if ( i1 .eq. nx .and. j1 .ne. ny .and. k1 .eq. nz ) then
  !       x1 = x(i1); x2 = 2.*x1 - x(nx-1); y1 = y(j1); y2 = y(j2); z1 = z(k1); z2 = 2.*z1 - z(nz-1)
  !       d111 = sqrt(sum((source-[x1,y1,z1])**2)); d211 = 0.
  !       d121 = sqrt(sum((source-[x1,y2,z1])**2)); d221 = 0.
  !       d112 = 0.; d212 = 0.
  !       d122 = 0.; d222 = 0.
  !       v111 = v(i1,j1,k1); v211 = 1.; v121 = v(i1,j2,k1); v221 = 1.
  !       v112 = 1.; v212 = 1.; v122 = 1.; v222 = 1.
  !     else if ( i1 .ne. nx .and. j1 .eq. ny .and. k1 .eq. nz ) then
  !       x1 = x(i1); x2 = x(i2); y1 = y(j1); y2 = 2.*y1 - y(ny-1); z1 = z(k1); z2 = 2.*z1 - z(nz-1)
  !       d111 = sqrt(sum((source-[x1,y1,z1])**2)); d211 = sqrt(sum((source-[x2,y1,z1])**2))
  !       d121 = 0.; d221 = 0.
  !       d112 = 0.; d212 = 0.
  !       d122 = 0.; d222 = 0.
  !       v111 = v(i1,j1,k1); v211 = v(i2,j1,k1); v121 = 1.; v221 = 1.
  !       v112 = 1.; v212 = 1.; v122 = 1.; v222 = 1.
  !     else if ( i1 .eq. nx .and. j1 .eq. ny .and. k1 .eq. nz ) then
  !       x1 = x(i1); x2 = 2.*x1 - x(nx-1); y1 = y(j1); y2 = 2.*y1 - y(ny-1); z1 = z(k1); z2 = 2.*z1 - z(nz-1)
  !       d111 = sqrt(sum((source-[x1,y1,z1])**2)); d211 = 0.
  !       d121 = 0.; d221 = 0.
  !       d112 = 0.; d212 = 0.
  !       d122 = 0.; d222 = 0.
  !       v111 = v(i1,j1,k1); v211 = 1.; v121 = 1.; v221 = 1.
  !       v112 = 1.; v212 = 1.; v122 = 1.; v222 = 1.
  !     else
  !       x1 = x(i1); x2 = x(i2); y1 = y(j1); y2 = y(j2); z1 = z(k1); z2 = z(k2)
  !       d111 = sqrt(sum((source-[x1,y1,z1])**2)); d211 = sqrt(sum((source-[x2,y1,z1])**2))
  !       d121 = sqrt(sum((source-[x1,y2,z1])**2)); d221 = sqrt(sum((source-[x2,y2,z1])**2))
  !       d112 = sqrt(sum((source-[x1,y1,z2])**2)); d212 = sqrt(sum((source-[x2,y1,z2])**2))
  !       d122 = sqrt(sum((source-[x1,y2,z2])**2)); d222 = sqrt(sum((source-[x2,y2,z2])**2))
  !       v111 = v(i1,j1,k1); v211 = v(i2,j1,k1); v121 = v(i1,j2,k1); v221 = v(i2,j2,k1)
  !       v112 = v(i1,j1,k2); v212 = v(i2,j1,k2); v122 = v(i1,j2,k2); v222 = v(i2,j2,k2)
  !     end if
  !
  !     ax = [ x2, x1, x2, x1, x2, x1, x2, x1 ]
  !     ay = [ y2, y2, y1, y1, y2, y2, y1, y1 ]
  !     az = [ z2, z2, z2, z2, z1, z1, z1, z1 ]
  !     av = [ v111, v211, v121, v221, v112, v212, v212, v222 ]
  !     ad = [ d111, d211, d121, d221, d112, d212, d212, d222 ]
  !     N = abs( (ax - xq) * (ay - yq) * (az - zq) ) / abs( (x2 - x1) * (y2 - y1) * (z2 -z1) )
  !     vq = sqrt(sum((source-[xq,yq,zq])**2)) / dot_product(ad / av, N)
  !   end if
  !   return
  ! end function interp3

  function slow2tt3(slow, nz, nx, ny, dz, dx, dy, zs, xs, ys, zr, xr, yr, &
                    n_sweep, nsrc, nrcv, n_threads) result(tt)
    real(kind = 8) :: tt(nrcv,nsrc)
    integer(kind = 4), intent(in) :: nz, nx, ny, n_sweep, nsrc, nrcv
    integer(kind = 4), intent(in), optional :: n_threads
    real(kind = 8), intent(in) :: slow(nz,nx,ny), dz, dx, dy, zs(nsrc), &
      xs(nsrc), ys(nsrc), zr(nrcv), xr(nrcv), yr(nrcv)
    integer(kind = 4) :: i, j, k, n1, n2
    real(kind = 8), dimension(:), allocatable :: ax, az, ay
    real(kind = 8), dimension(:,:), allocatable :: tcalc, rcv, src
    real(kind = 8), dimension(:,:,:), allocatable :: tmp

    if ( present(n_threads) ) call omp_set_num_threads(n_threads)

    ! Switch sources and stations to minimize calls to eikonals
    n1 = min(nrcv, nsrc)
    n2 = max(nrcv, nsrc)
    if ( n1 .eq. nsrc ) then
      rcv = reshape([ zr, xr, yr ], shape = [ n2, 3 ], order = [ 1, 2 ])
      src = reshape([ zs, xs, ys ], shape = [ n1, 3 ], order = [ 1, 2 ])
    else
      rcv = reshape([ zs, xs, ys ], shape = [ n2, 3 ], order = [ 1, 2 ])
      src = reshape([ zr, xr, yr ], shape = [ n1, 3 ], order = [ 1, 2 ])
    end if

    ! Initialize tcalc
    allocate(tcalc(n2,n1))

    ! Compute traveltimes using an eikonal solver
    az = dz * [ ( dfloat(k-1), k = 1, nz ) ]
    ax = dx * [ ( dfloat(k-1), k = 1, nx ) ]
    ay = dy * [ ( dfloat(k-1), k = 1, ny ) ]
    !$omp parallel default(shared) private(tmp, j)
    !$omp do schedule(runtime)
    do i = 1, n1
      allocate(tmp(nz,nx,ny))
      call solver3d(slow, tmp, nz, nx, ny, src(i,1), src(i,2), src(i,3), dz, dx, dy, n_sweep)
      do j = 1, n2
        tcalc(j,i) = interp3(az, ax, ay, tmp, rcv(j,1), rcv(j,2), rcv(j,3))
      end do
      deallocate(tmp)
    end do
    !$omp end parallel

    ! Transpose to reshape to [ nrcv, nsrc ]
    if ( n1 .eq. nrcv ) then
      tt = transpose(tcalc)
    else
      tt = tcalc
    end if
    return
  end function slow2tt3

end module fteik3d


!-----------------------------------------------------------------------
!     Subroutine:    chisq_magwell
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          07/05/2017
!     Description:   This subroutine calculates the magnetic well
!                    parameter as outline at:
!                    https://fusion.gat.com/pubs-ext/ComPlasmaPhys/A22135.pdf
!                    Here W > 0 implies stability
!-----------------------------------------------------------------------
      SUBROUTINE chisq_magwell(target,sigma,niter,iflag)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stellopt_runtime
      USE equil_utils
      USE stellopt_targets

!-----------------------------------------------------------------------
!     Input/Output Variables
!
!-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL(rprec), INTENT(in)    ::  target(nsd)
      REAL(rprec), INTENT(in)    ::  sigma(nsd)
      INTEGER,     INTENT(in)    ::  niter
      INTEGER,     INTENT(inout) ::  iflag

!-----------------------------------------------------------------------
!     Local Variables
!
!-----------------------------------------------------------------------
      INTEGER     :: ik, ier
      REAL(rprec) :: modb, Bsqav, dBsqav, p, pp, W, Vp,temp1, temp2, &
                     rhosqav, V, Bav
!----------------------------------------------------------------------
!     BEGIN SUBROUTINE
!----------------------------------------------------------------------
      IF (iflag < 0) RETURN
      ik = COUNT(sigma < bigno)
      IF (iflag == 1) WRITE(iunit_out,'(A,2(2X,I3.3))') 'MAGWELL ',ik,7
      IF (iflag == 1) WRITE(iunit_out,'(A)') 'TARGET  SIGMA  MAGWELL  <B**2>  P  dP/drho k'
      IF (niter >= 0) THEN
         DO ik = 1, nsd
            IF (sigma(ik) >= bigno) CYCLE
            CALL get_equil_Bav(rho(ik),Bav,Bsqav,ier,dBsqav) ! stel_tools (rho)
            CALL get_equil_volume(shat(ik),V,ier,Vp)
            CALL get_equil_p(shat(ik),p,ier,pp)
            W = V*(2*mu0*pp/Vp+dBsqav)/Bsqav
            ! Output value
            mtargets = mtargets + 1
            targets(mtargets) = target(ik)
            sigmas(mtargets)  = sigma(ik)
            vals(mtargets)    = W
            IF (iflag == 1) WRITE(iunit_out,'(6ES22.12E3,2X,I3.3)') target(ik),sigma(ik),W, Bsqav, p, pp, ik
         END DO
      ELSE
         DO ik = 1, nsd
            IF (sigma(ik) >= bigno) CYCLE
            mtargets = mtargets + 1
            IF (niter == -2) target_dex(mtargets)=jtarget_magwell
         END DO
      END IF
      RETURN
!----------------------------------------------------------------------
!     END SUBROUTINE
!----------------------------------------------------------------------
      END SUBROUTINE chisq_magwell


      subroutine locate(vardp,layern,flyern,tpbtfg)
c
c     +++PURPOSE+++
c     This is a subroutines to locate the soil layer and finer soil layer number
c     of certain depth.
c     Each soil layer was divided into 10 thin layers for frost simulation.
c     In the tillage zone (top two 10cm thick soil layers) the fine layer thickness is 1 cm.
c     While in the untilled zone (20cm thick each layer) the fine layer thickness is 2cm.
c
c     Authors(s):  Shuhui Dun, WSU
c     Date: 02/22/2008
c     Verified by: Joan Wu, WSU
c
c     ----------------------------------------------
c
c     +++ARGUMENT DECLARATIONS+++
      integer layern,flyern,tpbtfg
      real vardp
c
c     +++ARGUMENT DEFINITIONS+++
c     layerN - soil layer number
c     flyerN - finer soil layer number
c     tpbtfg - a flag for  start point or ending point is required,
c              0 for starting point and 1 for ending point.
c     vardp  - depth variable
c
c     +++PARAMETERS+++
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pmxpln.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
c
c     +++COMMON BLOCKS+++
      include 'cflgfs.inc'
      include  'cwater.inc'
      include  'cstruc.inc'
c     fine layer for frost simulation
c
c     +++LOCAL VARIABLES+++
c
      real tmpvr1,tmpvr2,tmpvr3,fthick
c
c     + + + DATA INITIALIZATIONS + + +

c     convert depth from cm to mm
      tmpvr1 = vardp *1000

c
c     minimum depth is 10mm
      if (tmpvr1 .lt. 10.) then
           layerN = 1
           flyern = 1
           return
      endif
c
c     The top 2 layers (20cm) are each 10cm deep
      if (tmpvr1.lt.200) then
c     In the tillage layer soil layer depth is 10 cm.
           layern = int(tmpvr1/100.) + 1
           tmpvr2 = mod(tmpvr1,100.)
c          normally soil layer thickness will be 10cm, except
c          for last layer. nfine() should be set to less fine layers for the last
c          partial layer.
           fthick = (dg(layern,iplane)*1000)/nfine(layern)
           flyern = int(tmpvr2/fthick) + 1
           tmpvr3 = mod(tmpvr2,fthick)
      else
c     Below the tillage layer soil layer depth is 20cm
           layern = int(tmpvr1/200.) + 2
           tmpvr2 = mod(tmpvr1,200.)
c          normally soil layer thickness will be 20cm, except
c          for last layer. nfine() should be set to less fine layers for the last
c          partial layer.
           fthick = (dg(layern,iplane)*1000)/nfine(layern)
           flyern = int(tmpvr2/fthick) + 1
           tmpvr3 = mod(tmpvr2,fthick)
      endif
c
      if(tpbtfg.eq.1) then
c     Ending point is different than the starting point at soil layer division
          if (abs(tmpvr2).lt.1.0) then
             layern = layern - 1
             flyern = nfine(layern)
           elseif (abs(tmpvr3).lt.1.0) then
             flyern = flyern -1
           endif
      endif
c
      return
      end


       subroutine transport(nbox_dum, x, K_dum, psi_dum,
     &                      invol_dum, dxdt)
! atmosphere-3-box-ocean carbon cycle model
! evaluate rates of change due to transport
! mick follows, march 2015/ june 2016
       implicit none
       INTEGER :: nbox_dum
       REAL*8, DIMENSION(nbox_dum):: x
       REAL*8, DIMENSION(nbox_dum,nbox_dum):: K_dum
       REAL*8 :: psi_dum
       REAL*8, DIMENSION(nbox_dum):: invol_dum
       REAL*8, DIMENSION(nbox_dum):: dxdt
!
       dxdt(1) = invol_dum(1) * (
     &       psi_dum*(x(3)-x(1))
     &     + K_dum(3,1)*(x(3)-x(1))
     &     + K_dum(2,1)*(x(2)-x(1))
     &       )
       dxdt(2) = invol_dum(2) * (
     &       psi_dum*(x(1)-x(2))
     &     + K_dum(1,2)*(x(1)-x(2))
     &     + K_dum(3,2)*(x(3)-x(2))
     &       )
       dxdt(3) = invol_dum(3) * (
     &       psi_dum*(x(2)-x(3))
     &     + K_dum(2,3)*(x(2)-x(3))
     &     + K_dum(1,3)*(x(1)-x(3))
     &       )

       return
       end


      subroutine scaleset_m3456(p,mu0)
c--- subroutine to calculate dynamic scale equal to
c--- invariant mass of particles 3, 4, 5 and 6
      implicit none
      include 'constants.f'
      include 'process.f'
      double precision p(mxpart,4),mu0

      if(
     &   (case .eq. 'WWqqbr') .or.
     &   (case .eq. 'WWnpol') .or.
     &   (case .eq. 'WW_jet') .or.
     &   (case .eq. 'WZbbar') .or.
     &   (case .eq. 'ZZlept') .or.
     &   (case .eq. 'WHbbar') .or.
     &   (case .eq. 'WHgaga') .or.
     &   (case .eq. 'ZHbbar') .or.
     &   (case .eq. 'ZHgaga') .or.
     &   (case .eq. 'HWW_4l') .or.
     &   (case .eq. 'HWW_tb') .or.
     &   (case .eq. 'HWWint') .or.
     &   (case .eq. 'HWWH+i') .or.
     &   (case .eq. 'ggWW4l') .or.
     &   (case .eq. 'ggWWbx') .or.
     &   (case .eq. 'HZZ_4l') .or.
     &   (case .eq. 'HZZ_tb') .or.
     &   (case .eq. 'HZZint') .or.
     &   (case .eq. 'HZZH+i') .or.
     &   (case .eq. 'HZZqgI') .or.
     &   (case .eq. 'HZZ+jt') .or.
     &   (case .eq. 'HWWjet') .or.
     &   (case .eq. 'HZZjet') .or.
     &   (case .eq. 'HWW2jt') .or.
     &   (case .eq. 'HZZ2jt') .or.
     &   (case .eq. 'qq_HZZ') .or.
     &   (case .eq. 'fourga') .or.
     &   (case .eq. 'W_2gam') .or.
     &   (case .eq. 'Z_2gam') .or.
     &   (case .eq. 'HmZZ4l') .or.
     &   (case .eq. 'HVV_tb') .or.
     &   (case .eq. 'ggVV4l') .or.
     &   (case .eq. 'ggVVbx') .or.
     &   (case .eq. 'ggZZ4l') .or.
     &   (case .eq. 'ggZZbx') .or.
     &   (case .eq. 'HmZZ4l') .or.
     &   (case .eq. 'qqZZqq') .or.
     &   (case .eq. 'qqWWqq') .or.
     &   (case .eq. 'qqVVqq')
     & ) then
        mu0=(p(3,4)+p(4,4)+p(5,4)+p(6,4))**2
     &     -(p(3,1)+p(4,1)+p(5,1)+p(6,1))**2
     &     -(p(3,2)+p(4,2)+p(5,2)+p(6,2))**2
     &     -(p(3,3)+p(4,3)+p(5,3)+p(6,3))**2
        mu0=dsqrt(dabs(mu0))
      else
        write(6,*)'dynamicscale m(3456) not supported for this process.'
        stop
      endif

      return
      end


MODULE mcspline
CONTAINS

SUBROUTINE cspline(x, xony, score, y, n, r, T, JJ, lam)

  IMPLICIT NONE

! Input arguments
  INTEGER, INTENT(in) :: n
  REAL*8,  INTENT(in), DIMENSION(N) :: y
!f2py optional , depend(sal) :: n=len(y)
  !> lambda parameter
  REAL*8,  INTENT(in) :: lam
  REAL*8,  INTENT(in) :: T
  INTEGER, INTENT(in) :: JJ
  INTEGER, INTENT(in) :: r
! Output arguments
  REAL*8, INTENT(out) :: score
  REAL*8, INTENT(out) :: x(r*n+r-1)
  REAL*8, INTENT(out) :: xONy(n)
! REAL*8, INTENT(out) :: x(25)

! Local variables
  REAL*8, DIMENSION(:), ALLOCATABLE :: c, e, f, w, z
  REAL*8 :: a0, a1, d
  COMPLEX (kind=8) :: a2, x1, x2, alpha, beta, atmp
  REAL*8 :: fac1, fac2
  REAL*8 :: elim, flim, glim, hlim, qlim
  REAL*8 :: g1, g2, h
  REAL*8 :: j1, j2, j3, j4
  REAL*8 :: lamc, lamr, mu, q, sq
  REAL*8 :: Tcu
  REAL*8 :: tmp1, tmp2, tmp3, tmp4
  REAL*8 :: tr, tr1, tr2, tr3
  REAL*8 :: v
  INTEGER :: ir, nc
  INTEGER :: r2, rn, rsq
  INTEGER :: i, j, k
  INTEGER :: NN, m

  nc = CEILING(REAL(n)/REAL(2.))
  Tcu = T**3
  rn = r*n

! Initialize output vector 'x' with zero for all 'm' members
  m = r*n+r-1
  x = 0.0d0

! print *, '2) Allocate c, w, z'
  ALLOCATE(c(n)) ; c = 0.0d0
  ALLOCATE(w(n-2)) ; w = 0.0d0
  ALLOCATE(z(n)) ; z = 0.0d0

  DO j=1,n-2
     w(j) = y(j)-2*y(j+1)+y(j+2)
  END DO

! print *, '3) determine lamr, a0, a1, a2, x1, x2'
  lamr = lam*Tcu
  a0 = 6.d0 + lamr*2.d0/3.d0
  a1 = 4.d0 - lamr/6.d0
  atmp = a1**2 - 4.d0*(a0-2.d0)
  a2 = SQRT(atmp)
  x1 =  (a1 + a2) / 2.d0
  x2 = -(a2 - a1) / 2.d0
! print *,' a1**2 - 4.d0*(a0-2.d0) = ', atmp
! print *, 'a0, a1, a2 =', a0, a1, a2
! print *, 'x1, x2 =', x1, x2

! print *, '4) determine alpha, beta'
  IF (lamr > 24.d0) THEN
     alpha = 0.5d0*(x1 + SQRT(x1**2-4.d0))
     beta  = 0.5d0*(x2 + SQRT(x2**2-4.d0))
  ELSE IF (lamr < 24.d0) THEN
     alpha = 0.5d0*(x1 - SQRT(x1**2-4.d0))
     beta  = 0.5d0*(x2 - SQRT(x2**2-4))
  ELSE
     alpha = 0.5d0*(x1 - SQRT(x1**2-4.d0))
     beta  = 0.5d0*(x2 + SQRT(x2**2-4.d0))
  END IF
! print *, 'alpha, beta = ', alpha, beta

! IF (JJ > LOG10(alpha*beta) - (nc-1)*2*LOG10(ABS(alpha))) THEN
  IF (JJ > LOG10(DBLE(alpha*beta)) - (nc-1)*2*LOG10(ABS(alpha))) THEN
     !print *, '5) JJ if block: GREATER THAN'

     !Use untruncated algorithm since NN > nc-2
     !Factor coefficient matrix, solve triangular systems, find trace

!    IF (ALLOCATED(e)) DEALLOCATE(e)
     ALLOCATE(e(n-2))
     e = 0.0d0

!    IF (ALLOCATED(f)) DEALLOCATE(f)
     ALLOCATE(f(n-2))
     f = 0.0d0

     d = a0
     f(1) = 1.d0 / d
     c(2) = f(1)*w(1)
     mu = a1
     e(1) = mu*f(1)
     d = a0-mu*e(1)
     f(2) = 1.d0 / d
     c(3) = f(2)*(w(2)+mu*c(2))
     mu = a1 - e(1)
     e(2) = mu*f(2)

     DO j=3,n-2
        d = a0-mu*e(j-1)-f(j-2)
        f(j) = 1.d0 / d
        c(j+1) = f(j)*(w(j)+mu*c(j)-c(j-1))
        mu = a1 - e(j-1)
        e(j) = mu * f(j)
     END DO
     c(n-2) = c(n-2)+e(n-3)*c(n-1)

     DO j=n-4,1,-1
        c(j+1) = c(j+1) + e(j)*c(j+2) - f(j)*c(j+3)
     END DO

     g2 = f(n-2)
     tr1 = g2
     h = e(n-3)*g2
     tr2 = h
     g1 = f(n-3) + e(n-3)*h
     tr1 = tr1 + g1
     tr3=0

     DO k=n-4,n-nc,-1
        q = e(k)*h - f(k)*g2
        tr3 = tr3 + q
        h = e(k)*g1 - f(k)*h
        tr2 = tr2 + h
        g2 = g1
        g1 = f(k)*(1-q) + e(k)*h
        tr1 = tr1 + g1
     END DO

     q = e(n-nc-1)*h - f(n-nc-1)*g2
     tr3 = tr3 + q
     h = e(n-nc-1)*g1 - f(n-nc-1)*h
     tr2 = tr2 + h

     tr1 =  6.d0*(2.d0*tr1 - DBLE(MOD(n,2))*g1)
     tr2 = -8.d0*(2.d0*tr2 - (1 + DBLE(MOD(n,2)) )*h)
     tr3 =  2.d0*(2.d0*tr3 - DBLE(MOD(n,2))*q)
     tr = (tr1+tr2+tr3)/DBLE(n)

  ELSE
     !print *, '5) JJ if block: LESS than'
     !Use truncated algorithm since NN < nc-1
     !Factor coefficient matrix, solve triangular systems, find trace
     flim = alpha*beta
     elim = alpha + beta
     glim = flim*(1+flim) / ((1 - flim)*((1.d0+flim)**2 - elim**2))
     hlim = elim*glim/(1.d0+flim)
     qlim = elim*hlim - flim*glim
     NN = CEILING((LOG10(flim) - JJ) / (2*LOG10(ABS(alpha))))

     !print *, '6) Allocate e, f'
     IF (ALLOCATED(e)) DEALLOCATE(e)
     ALLOCATE(e(NN))
     e = 0.0d0

     IF (ALLOCATED(f)) DEALLOCATE(f)
     ALLOCATE(f(NN))
     f = 0.0d0

     !print *, '7) produce tr%, g%, etc.'
     d = a0
     f(1) = 1.d0 / d
     c(2) = f(1)*w(1)
     mu = a1
     e(1) = mu*f(1)
     d = a0 - mu*e(1)
     f(2) = 1.d0 / d
     c(3) = f(2)*(w(2) + mu*c(2))
     mu = a1 - e(1)
     e(2) = mu*f(2)
     g2 = flim
     tr1 = g2
     h = elim*g2
     tr2 = h
     g1 = flim+elim*h
     tr1 = tr1+g1
     tr3 = 0.d0

     !print *, '8) Loop to produce tr1 etc'
     DO j=3,NN
        d = a0 - mu*e(j-1) - f(j-2)
        f(j) = 1.d0 / d
        c(j+1) = f(j)*(w(j) + mu*c(j) - c(j-1))
        mu = a1 - e(j-1)
        e(j) = mu*f(j)
        q = elim*h - flim*g2
        tr3 = tr3 + q
        h = elim*g1 - flim*h
        tr2 = tr2+h
        g2 = g1
        g1 = flim*(1-q) + elim*h
        tr1 = tr1 + g1
     END DO

     !print *, '9) Compute tr1, tr2, tr3, tr, mu'
     tr1 = tr1+(nc-NN-1)*glim
     tr2 = tr2+(nc-NN)*hlim
     tr3 = tr3+(nc-NN)*qlim
     tr1 =  6.d0*(2.d0*tr1 - DBLE(MOD(n,2))*glim)
     tr2 = -8.d0*(2.d0*tr2 - (1.d0 + DBLE(MOD(n,2)) )*hlim)
     tr3 =  2.d0*(2.d0*tr3 - DBLE(MOD(n,2))*qlim)
     tr = (tr1 + tr2 + tr3)/DBLE(n)
     mu = a1 - elim

     !print *, '10) Compute c(j+1): first'
     !print *, 'c =', c
     !print *, 'NN, n =', NN, n
     !print *, 'flim, mu =', flim, mu
     DO j=NN+1,n-2
        c(j+1) = flim*(w(j) + mu*c(j)-c(j-1))
     END DO
     !print *, c
     !print *, '10) Compute c(n-2)'
     c(n-2) = c(n-2) + elim*c(n-1)

     !print *, '11) Compute c(j)'
     DO j=n-3,NN+2,-1
        c(j) = c(j) + elim*c(j+1) - flim*c(j+2)
     END DO

     !print *, '12) Compute c(j+1) : second'
     DO j=NN,1,-1
        c(j+1) = c(j+1) + e(j)*c(j+2) - f(j)*c(j+3)
     END DO

  END IF

! print *, '13) Compute score'
  !Compute GCV score
  z(1) = c(2)
  z(2) = c(3)-2*c(2)
  DO j=3,n-2
     z(j) = c(j-1)-2*c(j)+c(j+1)
  END DO

  z(n-1) = c(n-2)-2*c(n-1)
  z(n) = c(n-1)

  !m2f: sq=(z*z')/n
! sq = (z*TRANSPOSE(z))/n
! sq = MatMul(z,TRANSPOSE(z)) / DBLE(n)
! Compute the dot product of the vector z
  sq = sum (z * z)
  score = sq / tr**2

! print *, 'Funny x(r:rn:r) operation'
  !Compute estimates
  !x(r:r:rn)=y-z
  x(r:rn:r) = y-z
  IF (r < 8) THEN
     fac1 = x(2*r) - x(r)    - lamr*c(2)/6.d0
     fac2 = x(rn)  - x(rn-r) + lamr*c(n-1)/6.d0
     DO j=1,r-1
        j1 = DBLE(j)/DBLE(r)
        j2 = 1.d0 - j1
        v = lamr*j1*j2 / 6.d0
        j3 = v*(1.d0 + j1)
        j4 = v*(2.d0 - j1)
        DO i=1,n-1
           ir = i*r
           x(ir+j) = j2*x(ir) + j1*x(ir+r) - j3*c(i+1) - j4*c(i)
        END DO
        x(j)    = x(r)  - j2*fac1
        x(rn+j) = x(rn) + j1*fac2
     END DO
  ELSE
     lamc = lamr/(6*r**3)
     r2 = 2*r
     rsq = r**2
     DO i=1,n-1
        ir = i*r
        tmp1 = x(ir)   / r
        tmp2 = x(ir+r) / r
        tmp3 = lamc*c(i+1)
        tmp4 = lamc*c(i)
        DO j=1,r-1
           x(ir+j) = DBLE(r-j)*tmp1 + DBLE(j)*tmp2 - DBLE(j)*DBLE(rsq-j*j)*tmp3 &
                   - DBLE(j)*DBLE(r-j)*DBLE(r2-j)*tmp4
        END DO
     END DO
     tmp1 = x(r) - x(r+1)
     tmp2 = x(rn) - x(rn-1)
     DO j = 1,r-1
        x(j)    = x(r) + (r-j)*tmp1
        x(rn+j) = x(rn) + j*tmp2
     END DO
  END IF

  xony = x(r:m:r)

END SUBROUTINE cspline
END MODULE mcspline


!==========================================================================
elemental function gsw_grav (lat, p)
!==========================================================================
!
! Calculates acceleration due to gravity as a function of latitude and as
!  a function of pressure in the ocean.
!
! lat  =  latitude in decimal degress north                [ -90 ... +90 ]
!  p  =  sea pressure                                              [ dbar ]
!
! gsw_grav : grav  =  gravitational acceleration               [ m s^-2 ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_z_from_p

use gsw_mod_teos10_constants, only : deg2rad, gamma

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: lat, p

real (r8) :: gsw_grav

real (r8) :: sin2, gs, z

sin2 = sin(lat*deg2rad)**2
gs = 9.780327_r8*(1.0_r8 + (5.2792e-3_r8 + (2.32e-5_r8*sin2))*sin2)

z = gsw_z_from_p(p,lat)

gsw_grav = gs*(1.0_r8 - gamma*z)        ! z is the height corresponding to p.
                                        ! Note. In the ocean z is negative.
return
end function

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


module lfortran_intrinsic_sin
! Implicit dependencies
! abs impure/math
! modulo pure/math2
! min builtin/array
! max builtin/array
use iso_c_binding, only: c_double, c_int
use, intrinsic :: iso_fortran_env, only: sp => real32, dp => real64
implicit none
private
public sin

interface sin
    module procedure dsin
end interface

real(dp), parameter :: pi = 3.1415926535897932384626433832795_dp

contains

! sin --------------------------------------------------------------------------
! Our implementation here is based off of the C files from the Sun compiler
!
! Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved.
!
! Developed at SunSoft, a Sun Microsystems, Inc. business.
! Permission to use, copy, modify, and distribute this
! software is freely granted, provided that this notice
! is preserved.

! sin(x)
! https://www.netlib.org/fdlibm/s_sin.c
! Return sine function of x.
!
! kernel function:
!	__kernel_sin		... sine function on [-pi/4,pi/4]
!	__kernel_cos		... cose function on [-pi/4,pi/4]
!	__ieee754_rem_pio2	... argument reduction routine
!
! Method.
!      Let S,C and T denote the sin, cos and tan respectively on
!	[-PI/4, +PI/4]. Reduce the argument x to y1+y2 = x-k*pi/2
!	in [-pi/4 , +pi/4], and let n = k mod 4.
!	We have
!
!          n        sin(x)      cos(x)        tan(x)
!     ----------------------------------------------------------
!          0          S           C             T
!          1          C          -S            -1/T
!          2         -S          -C             T
!          3         -C           S            -1/T
!     ----------------------------------------------------------
!
! Special cases:
!      Let trig be any of sin, cos, or tan.
!      trig(+-INF)  is NaN, with signals;
!      trig(NaN)    is that NaN;
!
! Accuracy:
!	TRIG(x) returns trig(x) nearly rounded
!

real(dp) function dsin(x) result(r)
real(dp), intent(in) :: x
real(dp) :: y(2)
integer :: n
if (abs(x) < pi/4) then
    r = kernel_dsin(x, 0.0_dp, 0)
else
    n = rem_pio2_c(x, y)
    select case (modulo(n, 4))
        case (0)
            r =  kernel_dsin(y(1), y(2), 1)
        case (1)
            r =  kernel_dcos(y(1), y(2))
        case (2)
            r = -kernel_dsin(y(1), y(2), 1)
        case default
            r = -kernel_dcos(y(1), y(2))
    end select
end if
end function

!  __kernel_sin( x, y, iy)
! http://www.netlib.org/fdlibm/k_sin.c
!  kernel sin function on [-pi/4, pi/4], pi/4 ~ 0.7854
!  Input x is assumed to be bounded by ~pi/4 in magnitude.
!  Input y is the tail of x.
!  Input iy indicates whether y is 0. (if iy=0, y assume to be 0).
!
!  Algorithm
! 	1. Since sin(-x) = -sin(x), we need only to consider positive x.
! 	2. if x < 2^-27 (hx<0x3e400000 0), return x with inexact if x!=0.
! 	3. sin(x) is approximated by a polynomial of degree 13 on
! 	   [0,pi/4]
! 		  	         3            13
! 	   	sin(x) ~ x + S1*x + ... + S6*x
! 	   where
!
!  	|sin(x)         2     4     6     8     10     12  |     -58
!  	|----- - (1+S1*x +S2*x +S3*x +S4*x +S5*x  +S6*x   )| <= 2
!  	|  x 					           |
!
! 	4. sin(x+y) = sin(x) + sin'(x')*y
! 		    ~ sin(x) + (1-x*x/2)*y
! 	   For better accuracy, let
! 		     3      2      2      2      2
! 		r = x! (S2+x! (S3+x! (S4+x! (S5+x! S6))))
! 	   then                   3    2
! 		sin(x) = x + (S1*x + (x! (r-y/2)+y))

elemental real(dp) function kernel_dsin(x, y, iy) result(res)
real(dp), intent(in) :: x, y
integer, intent(in) :: iy
real(dp), parameter :: half = 5.00000000000000000000e-01_dp
real(dp), parameter :: S1 = -1.66666666666666324348e-01_dp
real(dp), parameter :: S2 =  8.33333333332248946124e-03_dp
real(dp), parameter :: S3 = -1.98412698298579493134e-04_dp
real(dp), parameter :: S4 =  2.75573137070700676789e-06_dp
real(dp), parameter :: S5 = -2.50507602534068634195e-08_dp
real(dp), parameter :: S6 =  1.58969099521155010221e-10_dp
real(dp) :: z, r, v
if (abs(x) < 2.0_dp**(-27)) then
    res = x
    return
end if
z = x*x
v = z*x
r = S2+z*(S3+z*(S4+z*(S5+z*S6)))
if (iy == 0) then
    res = x + v*(S1+z*r)
else
    res = x-((z*(half*y-v*r)-y)-v*S1)
end if
end function

! __kernel_cos( x,  y )
! https://www.netlib.org/fdlibm/k_cos.c
! kernel cos function on [-pi/4, pi/4], pi/4 ~ 0.785398164
! Input x is assumed to be bounded by ~pi/4 in magnitude.
! Input y is the tail of x.
!
! Algorithm
!	1. Since cos(-x) = cos(x), we need only to consider positive x.
!	2. if x < 2^-27 (hx<0x3e400000 0), return 1 with inexact if x!=0.
!	3. cos(x) is approximated by a polynomial of degree 14 on
!	   [0,pi/4]
!		  	                 4            14
!	   	cos(x) ~ 1 - x*x/2 + C1*x + ... + C6*x
!	   where the remez error is
!
! 	|              2     4     6     8     10    12     14 |     -58
! 	|cos(x)-(1-.5*x +C1*x +C2*x +C3*x +C4*x +C5*x  +C6*x  )| <= 2
! 	|    					               |
!
! 	               4     6     8     10    12     14
!	4. let r = C1*x +C2*x +C3*x +C4*x +C5*x  +C6*x  , then
!	       cos(x) = 1 - x*x/2 + r
!	   since cos(x+y) ~ cos(x) - sin(x)*y
!			  ~ cos(x) - x*y,
!	   a correction term is necessary in cos(x) and hence
!		cos(x+y) = 1 - (x*x/2 - (r - x*y))
!	   For better accuracy when x > 0.3, let qx = |x|/4 with
!	   the last 32 bits mask off, and if x > 0.78125, let qx = 0.28125.
!	   Then
!		cos(x+y) = (1-qx) - ((x*x/2-qx) - (r-x*y)).
!	   Note that 1-qx and (x*x/2-qx) is EXACT here, and the
!	   magnitude of the latter is at least a quarter of x*x/2,
!	   thus, reducing the rounding error in the subtraction.

elemental real(dp) function kernel_dcos(x, y) result(res)
real(dp), intent(in) :: x, y
real(dp), parameter :: one=  1.00000000000000000000e+00_dp
real(dp), parameter :: C1 =  4.16666666666666019037e-02_dp
real(dp), parameter :: C2 = -1.38888888888741095749e-03_dp
real(dp), parameter :: C3 =  2.48015872894767294178e-05_dp
real(dp), parameter :: C4 = -2.75573143513906633035e-07_dp
real(dp), parameter :: C5 =  2.08757232129817482790e-09_dp
real(dp), parameter :: C6 = -1.13596475577881948265e-11_dp
real(dp) :: z, r, qx, hz, a
if (abs(x) < 2.0_dp**(-27)) then
    res = one
    return
end if
z = x*x
r  = z*(C1+z*(C2+z*(C3+z*(C4+z*(C5+z*C6)))))
if (abs(x) < 0.3_dp) then
    res = one - (0.5_dp*z - (z*r - x*y))
else
    if (abs(x) > 0.78125_dp) then
        qx = 0.28125_dp
    else
        qx = abs(x)/4
    end if
    hz = 0.5_dp*z-qx
    a  = one-qx
    res = a - (hz - (z*r-x*y))
end if
end function

integer function rem_pio2_c(x, y) result(n)
! Computes 128bit float approximation of modulo(x, pi/2) returned
! as the sum of two 64bit floating point numbers y(1)+y(2)
! This function roughly implements:
!   y(1) = modulo(x, pi/2)         ! 64bit float
!   y(2) = modulo(x, pi/2) - y(1)  ! The exact tail
!   n = (x-y(1)) / (pi/2)
! The y(1) is the modulo, and y(2) is a tail. When added directly
! as y(1) + y(2) it will be equal to just y(1) in 64bit floats, but
! if used separately in polynomial approximations one can use y(2) to get
! higher accuracy.
real(dp), intent(in) :: x
real(dp), intent(out) :: y(2)

interface
    integer(c_int) function ieee754_rem_pio2(x, y) bind(c)
    use iso_c_binding, only: c_double, c_int
    real(c_double), value, intent(in) :: x
    real(c_double), intent(out) :: y(2)
    end function
end interface

n = ieee754_rem_pio2(x, y)
end function

! Our implementation here is designed around range reduction to [-pi/2, pi/2]
! Subsequently, we fit a 64 bit precision polynomials via Sollya (https://www.sollya.org/)
! -- Chebyshev (32 terms) --
! This has a theoretical approximation error bound of [-7.9489615048122632526e-41;7.9489615048122632526e-41]
! Due to rounding errors; we obtain a maximum error (w.r.t. gfortran) of ~ E-15 over [-10, 10]
! -- Remez (16 terms) -- [DEFAULT] (fewer terms)
! Due to rounding errors; we obtain a maximum error (w.r.t. gfortran) of ~ E-16 over [-10, 10]
! For large values, e.g. 2E10 we have an absolute error of E-7
! For huge(0) we have an absolute error of E-008
! TODO: Deal with very large numbers; the errors get worse above 2E10
! For huge(0.0) we have 3.4028234663852886E+038 -0.52187652333365853       0.99999251142364332        1.5218690347573018
!                          value                    gfortran sin             lfortran sin              absolute error

elemental real(dp) function dsin2(x) result(r)
real(dp), intent(in) :: x
real(dp) :: y
integer :: n
y = modulo(x, 2*pi)
y = min(y, pi - y)
y = max(y, -pi - y)
y = min(y, pi - y)
r = kernel_dsin2(y)
end function

! Accurate on [-pi/2,pi/2] to about 1e-16
elemental real(dp) function kernel_dsin2(x) result(res)
real(dp), intent(in) :: x
real(dp), parameter :: S1 = 0.9999999999999990771_dp
real(dp), parameter :: S2 = -0.16666666666664811048_dp
real(dp), parameter :: S3 = 8.333333333226519387e-3_dp
real(dp), parameter :: S4 = -1.9841269813888534497e-4_dp
real(dp), parameter :: S5 = 2.7557315514280769795e-6_dp
real(dp), parameter :: S6 = -2.5051823583393710429e-8_dp
real(dp), parameter :: S7 = 1.6046585911173017112e-10_dp
real(dp), parameter :: S8 = -7.3572396558796051923e-13_dp
real(dp) :: z
z = x*x
res = x * (S1+z*(S2+z*(S3+z*(S4+z*(S5+z*(S6+z*(S7+z*S8)))))))
end function

elemental real(dp) function kernel_dcos2(x) result(res)
real(dp), intent(in) :: x
real(dp), parameter :: C1 = 0.99999999999999999317_dp
real(dp), parameter :: C2 = 4.3522024034217346524e-18_dp
real(dp), parameter :: C3 = -0.49999999999999958516_dp
real(dp), parameter :: C4 = -8.242872826356848038e-17_dp
real(dp), parameter :: C5 = 4.166666666666261697e-2_dp
real(dp), parameter :: C6 = 4.0485005435941782636e-16_dp
real(dp), parameter :: C7 = -1.3888888888731381616e-3_dp
real(dp), parameter :: C8 = -8.721570096570797013e-16_dp
real(dp), parameter :: C9 = 2.4801587270604889267e-5_dp
real(dp), parameter :: C10 = 9.352687193379247843e-16_dp
real(dp), parameter :: C11 = -2.7557315787234544468e-7_dp
real(dp), parameter :: C12 = -5.2320806585871644286e-16_dp
real(dp), parameter :: C13 = 2.0876532326120694722e-9_dp
real(dp), parameter :: C14 = 1.4637857803935104813e-16_dp
real(dp), parameter :: C15 = -1.146215379106821115e-11_dp
real(dp), parameter :: C16 = -1.6185683697669940221e-17_dp
real(dp), parameter :: C17 = 4.6012969591571265687e-14_dp
! Remez16
res = C1  + x * (C2  + x * &
     (C3  + x * (C4  + x * &
     (C5  + x * (C6  + x * &
     (C7  + x * (C8  + x * &
     (C9  + x * (C10 + x * &
     (C11 + x * (C12 + x * &
     (C13 + x * (C14 + x * &
     (C15 + x * (C16 + x * C17)))))))))))))))
end function

real(dp) function dsin3(x) result(r)
real(dp), intent(in) :: x
real(dp) :: y
integer :: n
if (abs(x) < pi/4) then
    r = kernel_dsin2(x)
else
    n = rem_pio2(x, y)
    select case (modulo(n, 4))
        case (0)
            r =  kernel_dsin2(y)
        case (1)
            r =  kernel_dcos2(y)
        case (2)
            r = -kernel_dsin2(y)
        case default
            r = -kernel_dcos2(y)
    end select
end if
end function

integer function rem_pio2(x, y) result(n)
real(dp), intent(in) :: x
real(dp), intent(out) :: y
y = modulo(x, pi/2)
if (y > pi/4) y = y-pi/2
n = (x-y) / (pi/2)
end function

end module


#version 120

varying vec2 p;

uniform float param = 128.;

int mandel(vec2 c, int n)
{
    float res_r = 0.0;
    float res_i = 0.0;
    float res_r_tmp;
    int i = 0;
    while ((res_r * res_r + res_i * res_i < 4) && (i < n))
    {
        res_r_tmp = res_r;
        res_r = res_r * res_r - res_i * res_i + c.x;
        res_i = 2.0 * res_r_tmp * res_i + c.y;
        ++i;
    }
    return i;
}

#define KAHAN_ITER(I) \
    { \
        float y = I - c_; \
        float t = sum_ + y; \
        c_ = (t - sum_) - y; \
        sum_ = t; \
    }

float kahan_sum6(float i0, float i1, float i2, float i3, float i4, float i5)
{
    float sum_ = 0.0;
    float c_ = 0.0;
    KAHAN_ITER(i0)
    KAHAN_ITER(i1)
    KAHAN_ITER(i2)
    KAHAN_ITER(i3)
    KAHAN_ITER(i4)
    KAHAN_ITER(i5)
    return sum_;
}

#define KAHAN_SUM7(O1, O2, I0, I1, I2, I3, I4, I5, I6)\
{\
    float sum_ = 0.0;\
    float c_ = 0.0;\
    KAHAN_ITER(I0)\
    KAHAN_ITER(I1)\
    KAHAN_ITER(I2)\
    KAHAN_ITER(I3)\
    KAHAN_ITER(I4)\
    KAHAN_ITER(I5)\
    KAHAN_ITER(I6)\
    O1 = sum_; O2 = c_;\
}

#define KAHAN_SUM5(O1, O2, I0, I1, I2, I3, I4)\
{\
    float sum_ = 0.0;\
    float c_ = 0.0;\
    KAHAN_ITER(I0)\
    KAHAN_ITER(I1)\
    KAHAN_ITER(I2)\
    KAHAN_ITER(I3)\
    KAHAN_ITER(I4)\
    O1 = sum_; O2 = c_;\
}

#define SUM_SQR(A,B) A*A, 2*A*B, B*B

int mandel2(vec2 c, int n)
{
    float res_r0 = 0.0, res_r1 = 0.0;
    float res_i0 = 0.0, res_i1 = 0.0;

    float res_r0_tmp, res_r1_tmp;
    int i = 0;
    while ((kahan_sum6(SUM_SQR(res_r0,res_r1), SUM_SQR(res_i0,res_i1)) < 4) && (i < n))
    {
        res_r0_tmp = res_r0;
        res_r1_tmp = res_r1;

        KAHAN_SUM7(res_r0, res_r1,
            res_r0*res_r0, 2*res_r0*res_r1, res_r1*res_r1,
            -res_i0*res_i0, -2*res_i0*res_i1, -res_i1*res_i1,
            c.x);

        KAHAN_SUM5(res_i0, res_i1,
            2.0*res_r0_tmp*res_i0, 2.0*res_r1_tmp*res_i0, 2.0*res_r0_tmp*res_i1, 2.0*res_r1_tmp*res_i1,
            c.y);

        ++i;
    }
    return i;
}

void main()
{
    vec2 pp = p;
    pp.x = p.x * 1.5 - 0.5;
    pp.y *= 1.5;
    float color1 = 1. - mandel(pp, int(param)) / param;
    float color2 = 1. - mandel2(pp, int(param)) / param;
    gl_FragColor = vec4(color1, color2, 0.0, 1.);
}


      SUBROUTINE PL2PL (AR,BR,CR,DR, AX,BX,CX,DX, AP,BP,CP,DP)

C  Given a reference plane (R) and an intersecting crossing plane
C  (X), find the perpendicular plane (P), which contains the line of
C  intersection of R and X, and is perpendicular to R.

      REAL  AR,BR,CR,DR, AX,BX,CX,DX, AP,BP,CP,DP
      REAL  AL,BL,CL, PX,PY,PZ

C  get line of intersection of R and X
      CALL PL2LN (AR,BR,CR,DR, AX,BX,CX,DX, AL,BL,CL, PX,PY,PZ)
C  cross-prod of line and ref plane is attitude of P-plane
      CALL CROSSP ( AR,BR,CR, AL,BL,CL, AP,BP,CP)
C  solve for dp, given point on line:
      DP = -(AP*PX + BP*PY + CP*PZ)

      END