*DECK GAMIC
      REAL FUNCTION GAMIC (A, X)
C***BEGIN PROLOGUE  GAMIC
C***PURPOSE  Calculate the complementary incomplete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (GAMIC-S, DGAMIC-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   Evaluate the complementary incomplete gamma function
C
C   GAMIC = integral from X to infinity of EXP(-T) * T**(A-1.)  .
C
C   GAMIC is evaluated for arbitrary real values of A and for non-
C   negative values of X (even though GAMIC is defined for X .LT.
C   0.0), except that for X = 0 and A .LE. 0.0, GAMIC is undefined.
C
C   GAMIC, A, and X are REAL.
C
C   A slight deterioration of 2 or 3 digits accuracy will occur when
C   GAMIC is very large or very small in absolute value, because log-
C   arithmic variables are used.  Also, if the parameter A is very close
C   to a negative integer (but not a negative integer), there is a loss
C   of accuracy, which is reported if the result is less than half
C   machine precision.
C
C***REFERENCES  W. Gautschi, A computational procedure for incomplete
C                 gamma functions, ACM Transactions on Mathematical
C                 Software 5, 4 (December 1979), pp. 466-481.
C               W. Gautschi, Incomplete gamma functions, Algorithm 542,
C                 ACM Transactions on Mathematical Software 5, 4
C                 (December 1979), pp. 482-489.
C***ROUTINES CALLED  ALGAMS, ALNGAM, R1MACH, R9GMIC, R9GMIT, R9LGIC,
C                    R9LGIT, XERCLR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  GAMIC
      LOGICAL FIRST
      SAVE EPS, SQEPS, ALNEPS, BOT, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  GAMIC
      IF (FIRST) THEN
         EPS = 0.5*R1MACH(3)
         SQEPS = SQRT(R1MACH(4))
         ALNEPS = -LOG(R1MACH(3))
         BOT = LOG(R1MACH(1))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMIC', 'X IS NEGATIVE',
     +   2, 2)
C
      IF (X.GT.0.0) GO TO 20
      IF (A .LE. 0.0) CALL XERMSG ('SLATEC', 'GAMIC',
     +   'X = 0 AND A LE 0 SO GAMIC IS UNDEFINED', 3, 2)
C
      GAMIC = EXP (ALNGAM(A+1.0) - LOG(A))
      RETURN
C
 20   ALX = LOG(X)
      SGA = 1.0
      IF (A.NE.0.0) SGA = SIGN (1.0, A)
      MA = A + 0.5*SGA
      AEPS = A - MA
C
      IZERO = 0
      IF (X.GE.1.0) GO TO 60
C
      IF (A.GT.0.5 .OR. ABS(AEPS).GT.0.001) GO TO 50
      FM = -MA
      E = 2.0
      IF (FM.GT.1.0) E = 2.0*(FM+2.0)/(FM*FM-1.0)
      E = E - ALX*X**(-0.001)
      IF (E*ABS(AEPS).GT.EPS) GO TO 50
C
      GAMIC = R9GMIC (A, X, ALX)
      RETURN
C
 50   CALL ALGAMS (A+1.0, ALGAP1, SGNGAM)
      GSTAR = R9GMIT (A, X, ALGAP1, SGNGAM, ALX)
      IF (GSTAR.EQ.0.0) IZERO = 1
      IF (GSTAR.NE.0.0) ALNGS = LOG (ABS(GSTAR))
      IF (GSTAR.NE.0.0) SGNGS = SIGN (1.0, GSTAR)
      GO TO 70
C
 60   IF (A.LT.X) GAMIC = EXP (R9LGIC(A, X, ALX))
      IF (A.LT.X) RETURN
C
      SGNGAM = 1.0
      ALGAP1 = ALNGAM (A+1.0)
      SGNGS = 1.0
      ALNGS = R9LGIT (A, X, ALGAP1)
C
C EVALUATION OF GAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN.
C
 70   H = 1.0
      IF (IZERO.EQ.1) GO TO 80
C
      T = A*ALX + ALNGS
      IF (T.GT.ALNEPS) GO TO 90
      IF (T.GT.(-ALNEPS)) H = 1.0 - SGNGS*EXP(T)
C
      IF (ABS(H).LT.SQEPS) CALL XERCLR
      IF (ABS(H) .LT. SQEPS) CALL XERMSG ('SLATEC', 'GAMIC',
     +   'RESULT LT HALF PRECISION', 1, 1)
C
 80   SGNG = SIGN (1.0, H) * SGA * SGNGAM
      T = LOG(ABS(H)) + ALGAP1 - LOG(ABS(A))
      IF (T.LT.BOT) CALL XERCLR
      GAMIC = SGNG * EXP(T)
      RETURN
C
 90   SGNG = -SGNGS * SGA * SGNGAM
      T = T + ALGAP1 - LOG(ABS(A))
      IF (T.LT.BOT) CALL XERCLR
      GAMIC = SGNG * EXP(T)
      RETURN
C
      END


SUBROUTINE MGProlongation3DExplicit(PHIfine,PHIcoarse,FineGrid,CoarseGrid,GhostGridX,GhostGridY,GhostGridZ,Nzf,Nxf,Nyf,Nzc,Nxc,Nyc)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
REAL(KIND=long), DIMENSION(:,:), POINTER :: xf, yf, xc, yc
REAL(KIND=long), DIMENSION(:), POINTER :: zf, zc
TYPE (Level_def) :: FineGrid, CoarseGrid ! Grid information
INTEGER :: xcoarsen, ycoarsen, zcoarsen, GhostGridX, GhostGridY, GhostGridZ
INTEGER :: Nxf, Nyf, Nzf, Nxc, Nyc, Nzc, N, NS
REAL(KIND=long), DIMENSION(Nzf,Nxf,Nyf) :: PHIfine
REAL(KIND=long), DIMENSION(Nzc,Nxc,Nyc) :: PHIcoarse
INTEGER :: kc,jc,ic, XFAC, YFAC, ZFAC
INTEGER :: ifine, jfine, kfine
REAL(KIND=long) :: dx_W, dx_E, dy_S, dy_N, dz_D, dz_U, dxf, dyf, dzf, dzc

! Initialize output array
PHIfine = zero

! USE POINTERS TO ALREADY ALLOCATED GRID VECTORS
xf => FineGrid%x;   yf => FineGrid%y;   zf => FineGrid%z
xc => CoarseGrid%x; yc => CoarseGrid%y; zc => CoarseGrid%z

! coarsenig strategy is based on the physical grid sizes
Nxf = Nxf-2*GhostGridX
Nxc = Nxc-2*GhostGridX
Nyf = Nyf-2*GhostGridY
Nyc = Nyc-2*GhostGridY
Nzf = Nzf-GhostGridZ
Nzc = Nzc-GhostGridZ

!print*,'Nxf=',Nxf
!print*,'Nxc=',Nxc
!print*,'Nyf=',Nyf
!print*,'Nyc=',Nyc
!print*,'Nzf=',Nzf
!print*,'Nzc=',Nzc
!STOP

! Determine coarsening strategy for each dimension
xcoarsen = 0; ycoarsen = 0; zcoarsen = 0;
XFAC = 1; YFAC = 1; ZFAC = 1;
IF (Nxf>Nxc) THEN; xcoarsen = 1; XFAC=2; ENDIF
IF (Nyf>Nyc) THEN; ycoarsen = 1; YFAC=2; ENDIF
IF (Nzf>Nzc) THEN; zcoarsen = 1; ZFAC=2; ENDIF

! BUILD PROLONGATION OPERATOR
! Carry out x-, y-, and z-sweeps independently by first
! carrying out all direct injections as this will allow
! us to only work on the output array when sweeping in
! each direction.

! DIRECT INJECTION (OMIT FREE SURFACE LAYER)
!print*,'GhostGridX=',GhostGridX
!print*,'GhostGridY=',GhostGridY
!print*,'GhostGridZ=',GhostGridZ
!STOP
PHIfine(1+GhostGridZ:Nzf+GhostGridZ-1:ZFAC,1+GhostGridX:Nxf+GhostGridX:XFAC,1+GhostGridY:Nyf+GhostGridY:YFAC) = &
	PHIcoarse(1+GhostGridZ:Nzc+GhostGridZ-1,1+GhostGridX:Nxc+GhostGridX,1+GhostGridY:Nyc+GhostGridY)

! X-SWEEP
! DO LOOPS HAS BEEN ORDERED FOR EFFICIENCY (DUE TO dx's)
IF (XFAC==2) THEN
  DO jfine = 1+GhostGridY, Nyf+GhostGridY, YFAC
    DO ifine = 2+GhostGridX, Nxf+GhostGridX, XFAC
      dx_W = xf(ifine,jfine)   - xf(ifine-1,jfine)
      dx_E = xf(ifine+1,jfine) - xf(ifine,jfine)
	  dxf  = one/(dx_W + dx_E)
	  DO kfine = 1+GhostGridZ, Nzf+GhostGridZ-1, ZFAC ! FIXME: WE DO NOT PROLONGATE AT THE FREE SURFACE OR AT GHOST LAYER
		! linear interpolation
   		PHIfine(kfine,ifine,jfine) = (dx_E*PHIfine(kfine,ifine-1,jfine) + dx_W*PHIfine(kfine,ifine+1,jfine))*dxf
	  END DO
	END DO
  END DO
END IF
XFAC = 1

! Y-SWEEP
IF (YFAC==2) THEN
  DO ifine = 1+GhostGridX, Nxf+GhostGridX, XFAC
    DO jfine = 2+GhostGridY, Nyf+GhostGridY, YFAC
      dy_S = yf(ifine,jfine)   - yf(ifine,jfine-1)
      dy_N = yf(ifine,jfine+1) - yf(ifine,jfine)
	  dyf  = one/(dy_S + dy_N)
	  DO kfine = 1+GhostGridZ, Nzf+GhostGridZ-1, ZFAC ! FIXME: WE PROLONGATE AT THE FREE SURFACE
	    ! linear interpolation
	    PHIfine(kfine,ifine,jfine) = (dy_N*PHIfine(kfine,ifine,jfine-1) + dy_S*PHIfine(kfine,ifine,jfine+1))*dyf
	  END DO
	END DO
  END DO
END IF
YFAC = 1

! Z-SWEEP
! DO LOOPS HAS BEEN ORDERED FOR EFFICIENCY (DUE TO dz's)
IF (ZFAC==2) THEN
	DO kfine = 2+GhostGridZ, Nzf+GhostGridZ-1, ZFAC ! FIXME: WE DO NOT PROLONGATE AT THE FREE SURFACE
	    dz_D = zf(kfine)   - zf(kfine-1)
	    dz_U = zf(kfine+1) - zf(kfine)
	    dzf  = one/(dz_D + dz_U)
		DO jfine = 1+GhostGridY, Nyf+GhostGridY, YFAC
 			DO ifine = 1+GhostGridX, Nxf+GhostGridX, XFAC
			! linear interpolation
			PHIfine(kfine,ifine,jfine) = (dz_U*PHIfine(kfine-1,ifine,jfine) + dz_D*PHIfine(kfine+1,ifine,jfine))*dzf
		END DO
	END DO
  END DO
END IF

!IF (GhostGridZ==1) THEN
!    ! Approximate symmetric reflection about bottom
!	PHIfine(1,:,:) = PHIfine(3,:,:)
!ENDIF

if (0==1) then
! APPROXIMATE GHOST POINT VALUES ON FINE GRID??
! IMPOSE WALL BOUNDARY CONDITIONS THROUGH SYMMETRY (FIXME: needs to be fixed for curvilinear settings /APEK)
DO kfine = 1+GhostGridZ, Nzf+GhostGridZ, ZFAC
    DO jfine = 1+GhostGridY, Nyf+GhostGridY, YFAC
       ifine = 1 ! WEST
       PHIfine(kfine,ifine,jfine) = PHIfine(kfine,ifine+2,jfine)
       ifine = Nxf+GhostGridX*2 ! EAST
       PHIfine(kfine,ifine,jfine) = PHIfine(kfine,ifine-2,jfine)
  END DO
END DO

DO kfine = 1+GhostGridZ, Nzf+GhostGridZ, ZFAC
  DO ifine = 1+GhostGridX, Nxf+GhostGridX, XFAC
       jfine = 1 ! SOUTH
       PHIfine(kfine,ifine,jfine) = PHIfine(kfine,ifine,jfine+2)
       jfine = Nxf+GhostGridY*2 ! NORTH
       PHIfine(kfine,ifine,jfine) = PHIfine(kfine,ifine,jfine-2)
  END DO
END DO

kfine = 1
DO ifine = 1+GhostGridX, Nxf+GhostGridX, XFAC
  DO jfine = 1+GhostGridY, Nyf+GhostGridY, YFAC
     PHIfine(kfine,ifine,jfine) = PHIfine(kfine+2,ifine,jfine)
  END DO
END DO
end if
END SUBROUTINE MGProlongation3DExplicit


      SUBROUTINE LU(A,N,NDIM,IR,IC)
C  IT IS THE FIRST SUBROUTINE TO COMPUTE THE MX. INV.
      DIMENSION A(NDIM,1),IR(1),IC(1)
      DO 10I=1,N
      IR(I)=I
      IC(I)=I
10      CONTINUE
      K=1
      L=K
      M=K
      XMAX=ABS(A(K,K))
      DO 100I=K,N
      DO 100J=K,N
      Y=ABS(A(I,J))
      IF(XMAX.GE.Y) GOTO 100
      XMAX=Y
      L=I
      M=J
100     CONTINUE
      DO 1000K=1,N
      IRL=IR(L)
      IR(L)=IR(K)
      IR(K)=IRL
      ICM=IC(M)
      IC(M)=IC(K)
      IC(K)=ICM
      IF(L.EQ.K) GOTO 300
      DO 200J=1,N
      B=A(K,J)
      A(K,J)=A(L,J)
      A(L,J)=B
200     CONTINUE
300     IF(M.EQ.K) GOTO 500
      DO 400I=1,N
      B=A(I,K)
      A(I,K)=A(I,M)
       A(I,M)=B
400    CONTINUE
500     C=1./A(K,K)
      A(K,K)=C
      IF(K.EQ.N) GOTO 1000
      K1=K+1
      XMAX=ABS(A(K1,K1))
      L=K1
      M=K1
      DO 600I=K1,N
       A(I,K)=C*A(I,K)
600     CONTINUE
      DO 800I=K1,N
      B=A(I,K)
      DO 800J=K1,N
      A(I,J)=A(I,J)-B*A(K,J)
      Y=ABS(A(I,J))
      IF(XMAX.GE.Y) GOTO 800
      XMAX=Y
      L=I
      M=J
800    CONTINUE
1000  CONTINUE
      RETURN
      END
      SUBROUTINE SOLVE(F,A,K,N,NDIM,IR,IC)
C   IT IS THE SECOND PART OF THE MATRIX INVERSION
      DIMENSION A(NDIM,1),F(NDIM,1),IR(1),IC(1)
      COMMON /CTMPG/ G(2000)
C
C
      IF (N.GT.2000) THEN
         write(6,*) 'Abort IN Subrtouine SOLVE: N>2000, N=',N
         call exitt
      ENDIF
C
      N1=N+1
      DO 1000KK=1,K
      DO 100I=1,N
      IRI=IR(I)
        G(I)=F(IRI,KK)
100     CONTINUE
      DO 400I=2,N
      I1=I-1
      B=G(I)
      DO 300J=1,I1
        B=B-A(I,J)*G(J)
300     CONTINUE
        G(I)=B
400     CONTINUE
      DO 700IT=1,N
      I=N1-IT
      I1=I+1
      B=G(I)
      IF(I.EQ.N) GOTO 701
      DO 600J=I1,N
        B=B-A(I,J)*G(J)
600     CONTINUE
701     G(I)=B*A(I,I)
700     CONTINUE
      DO 900I=1,N
      ICI=IC(I)
        F(ICI,KK)=G(I)
900     CONTINUE
1000    CONTINUE
      RETURN
      END


module fourier_interpolation

  use constants,  only: dp, two_pi, cmplx_i
  implicit none

  private

  type, public  ::  interp_type
    integer                                       ::  ndims = 0
    integer,          dimension(2)                ::  grid_size = (/ 0, 0 /)
    real(kind=dp),    dimension(:,:), allocatable ::  grid_values
    complex(kind=dp), dimension(:,:), allocatable ::  fourier_coeffs
    logical                                       ::  ready = .false.
  end type interp_type

  ! likely won't need 1D routines, but might as well keep anyway
  interface dft_forward
    module procedure dft_forward_1d
    module procedure dft_forward_2d
  end interface dft_forward

  interface dft_backward
    module procedure dft_backward_1d
    module procedure dft_backward_2d
  end interface dft_backward

  interface fourier_interpolation_potential
    module procedure fourier_interpolation_potential_1d
    module procedure fourier_interpolation_potential_2d
  end interface fourier_interpolation_potential

  public  ::  fourier_interpolation_init
  public  ::  fourier_interpolation_read
  public  ::  fourier_interpolation_transform
  public  ::  fourier_interpolation_potential
  public  ::  fourier_interpolation_deallocate

contains

subroutine fourier_interpolation_init(keyword, interp, dealloc_real)
  use io, only: io_err
  implicit none
  character(len=*),             intent(in)      ::  keyword
  type(interp_type),            intent(inout)   ::  interp
  logical,            optional, intent(in)      ::  dealloc_real    ! default false
  integer ::  istat

  ! read real values at grid points from IO internal hash table
  call fourier_interpolation_read(keyword, interp)

  call fourier_interpolation_transform(interp)

  ! only deallocate if we explicitly ask to (safest option)
  if (present(dealloc_real) .and. dealloc_real) then
    deallocate(interp%grid_values, stat=istat)
    if (istat .ne. 0) call io_err("fourier_interpolation_init: Could not deallocate interp%grid_values")
  end if
end subroutine fourier_interpolation_init

subroutine fourier_interpolation_transform(interp)
  use io, only: io_err
  implicit none
  type(interp_type),  intent(inout)   ::  interp

  if (.not. allocated(interp%grid_values)) then
    call io_err("fourier_interpolation_transform: interp%grid_values array not allocated")
  end if

  ! forward transform - manually select between 1D and 2D and pass a slice if necessary
  if (interp%ndims .eq. 1) then
    call dft_forward_1d(interp%grid_values(:,0), interp%fourier_coeffs(:,0))
  else if (interp%ndims .eq. 2) then
    call dft_forward_2d(interp%grid_values, interp%fourier_coeffs)
  else
    call io_err("fourier_interpolation_transform: interp%ndims should be 1 or 2")
  end if
  interp%ready = .true.
end subroutine fourier_interpolation_transform

subroutine fourier_interpolation_allocate(interp)
  use io, only: io_err
  implicit none
  type(interp_type),            intent(inout)   ::  interp
  integer ::  istat

  if ((interp%grid_size(1) .lt. 1) .or. (interp%grid_size(2) .lt. 1)) then
    call io_err("fourier_interpolation_allocate: grid is not >= 1 along all dimensions")
  end if

  allocate(interp%grid_values(0:interp%grid_size(1)-1, 0:interp%grid_size(2)-1), stat=istat)
  if (istat .ne. 0) call io_err("fourier_interpolation_allocate: Could not allocate interp%grid_values")

  allocate(interp%fourier_coeffs(0:interp%grid_size(1)-1, 0:interp%grid_size(2)-1), stat=istat)
  if (istat .ne. 0) call io_err("fourier_interpolation_allocate: Could not allocate interp%fourier_coeffs")
end subroutine fourier_interpolation_allocate

subroutine fourier_interpolation_deallocate(interp)
  use io, only: io_err
  implicit none
  type(interp_type),            intent(inout)   ::  interp
  integer ::  istat

  ! might have deallocated this already..
  if (allocated(interp%grid_values)) then
    deallocate(interp%grid_values, stat=istat)
    if (istat .ne. 0) call io_err("fourier_interpolation_deallocate: Could not deallocate interp%grid_values")
  end if

  ! no reason why this should not be allocated if we are calling this, but let's be safe (could throw error)
  if (allocated(interp%fourier_coeffs)) then
    deallocate(interp%fourier_coeffs, stat=istat)
    if (istat .ne. 0) call io_err("fourier_interpolation_deallocate: Could not deallocate interp%fourier_coeffs")
  end if

  ! why not?
  interp%grid_size(:) = 0
  interp%ndims = 0
  interp%ready = .false.
end subroutine fourier_interpolation_deallocate

subroutine fourier_interpolation_read(keyword, interp)
  use io, only: max_line_len, io_input_get_data,  io_str_get_token, io_str_get_num_tokens, io_err
  implicit none
  character(len=*),             intent(in)    ::  keyword
  type(interp_type),            intent(inout) ::  interp

  character(len=max_line_len),  allocatable,  dimension(:)  ::  values
  character(len=max_line_len) ::  str
  character(len=10)           ::  line_num_str            ! any possible line num..
  logical                     ::  found
  integer,  dimension(2)      ::  grid_indices
  integer                     ::  itoken, iline, nlines
  integer                     ::  istat

  ! Error checking kept fairly basic here:
  !   - Don't check whether value supplied more than once
  !   - Don't check that all values are supplied.
  ! (Benefit: Don't enforce any particular ordering of points)

  ! Block should look like:
  !   Note: values are: int, [int,] real (for all lines after first)

  ! for 1D:
  ! npts
  ! 0           value(1)
  ! npts-1      value(npts)

  ! for 2D:
  ! na      nb
  ! 0       0       value(1)
  ! ...     ...     ...
  ! na-1    nb-1    value(na*nb)

  ! don't need to worry about length of keyword, io module will complain if too long (as does hash..)
  call io_input_get_data(keyword, values, found)
  if (.not. found) call io_err("fourier_interpolation_read: "//trim(keyword)//" not found in input hash")

  nlines = size(values, 1)

  ! must have at least two lines
  if (nlines .lt. 2) call io_err("fourier_interpolation_read: "//trim(keyword)//" block must be >= 2 lines long")

  ! check first line has correct number of tokens (1 for 1D,   2 for 2D)
  interp%ndims = io_str_get_num_tokens(values(1))
  if ((interp%ndims .ne. 1) .and. (interp%ndims .ne. 2))  &
    & call io_err("fourier_interpolation_read: First line of "//trim(keyword)//" block must have 1 or 2 values (ndims)")

  ! get number of grid points
  if (interp%ndims .eq. 1) then
    read(values(1), *, iostat=istat) interp%grid_size(1)
    interp%grid_size(2) = 1
  else
    ! interp%ndims .eq. 2
    read(values(1), *, iostat=istat) interp%grid_size(1), interp%grid_size(2)
  end if
  if (istat .ne. 0) call io_err("fourier_interpolation_read: "//trim(keyword)//" block: could not read number of grid points")

  ! check number of lines makes sense
  if (nlines-1 .ne. interp%grid_size(1)*interp%grid_size(2)) &
    & call io_err("fourier_interpolation_read: "//trim(keyword)//" block has unexpected number of grid points")

  call fourier_interpolation_allocate(interp) ! will check we have valid number of grid points along each dim

  interp%grid_values(:,:) = 0.0_dp            ! prevent doing DFT of uninitialized data if grid points missing
                                              ! (due setting one twice, for example) - result will likely be wrong though..

  ! values can be in any order, but must all be there for this to work properly
  ! Note, could create logical array of size Nx*Ny and check off each element when added, then look to see if any not set..
  do iline = 2, nlines
    ! store line num as string for useful error messages..
    write(line_num_str, '(I10)', iostat=istat) iline
    if (istat .ne. 0) call io_err("fourier_interpolation_read: Could not store line number string")
    line_num_str = adjustl(line_num_str)  ! remove lhs padding

    if (io_str_get_num_tokens(values(iline)) .ne. interp%ndims+1) then
      call io_err("fourier_interpolation_read: line "//trim(line_num_str) &
                  & //" in "//trim(keyword)//" block must have ndims+1 values")
    end if

    grid_indices(:) = 0
    ! check that grid indices are valid (ie: >=0, <na or <nb)
    do itoken = 1, interp%ndims    ! ia, ib

      str = io_str_get_token(values(iline), itoken)
      read(str, *, iostat=istat) grid_indices(itoken)
      if (istat .ne. 0) then
        call io_err("fourier_interpolation_read: "//trim(keyword)//&
          & " could not read grid point index on line "//trim(line_num_str)//" of block")
      end if

      if ((grid_indices(itoken) .lt. 0) .or. (grid_indices(itoken) .ge. interp%grid_size(itoken))) then
        call io_err("fourier_interpolation_read: "//trim(keyword)//" invalid grid point index on line "&
          &//trim(line_num_str)//" of block")
      end if
    end do

    str = io_str_get_token(values(iline), interp%ndims+1)
    read(str, *, iostat=istat) interp%grid_values(grid_indices(1), grid_indices(2))
    if (istat .ne. 0) then
      call io_err("fourier_interpolation_read: "//trim(keyword)//" could not read grid point on line "&
        &//trim(line_num_str)//" of block")
    end if
  end do
end subroutine fourier_interpolation_read

subroutine dft_forward_1d(rinput, coutput)
  use io, only: io_err
  implicit none
  real(kind=dp),    dimension(0:), intent(in)  ::  rinput
  complex(kind=dp), dimension(0:), intent(out) ::  coutput
  ! local vars:
  integer               ::  n, k, nelements

  ! computes the 1D DFT (see numerical recipes)

  if (size(rinput,1) .ne. size(coutput,1)) call io_err("dft_forward_1d: Size of two arrays should match")

  nelements = size(rinput,1)

  coutput(:) = cmplx(0.0_dp, 0.0_dp, dp)

  do n = 0, nelements-1
    do k = 0, nelements-1
      coutput(n) = coutput(n) + rinput(k) * exp( (two_pi*real(k*n,dp)/real(nelements,dp)) * cmplx_i )
    end do !k
  end do !n
end subroutine dft_forward_1d

subroutine dft_forward_2d(rinput, coutput)
  use io, only: io_err
  implicit none
  real(kind=dp),    dimension(0:,0:), intent(in)  ::  rinput
  complex(kind=dp), dimension(0:,0:), intent(out) ::  coutput
  ! local vars:
  complex(kind=dp)      ::  contrib
  integer               ::  n1, n2, k1, k2, nelements1, nelements2

  ! computes the 2D DFT (see numerical recipes)
  ! could do this with nested 1D transforms (to save code repetition) but clearer to have it all in one routine

  if ((size(rinput,1) .ne. size(coutput,1)) .or. &
  &   (size(rinput,2) .ne. size(coutput,2))) call io_err("dft_forward_2d: Size of two arrays should match")

  nelements1 = size(rinput,1)
  nelements2 = size(rinput,2)

  coutput(:,:) = cmplx(0.0_dp, 0.0_dp, dp)

  do n2 = 0, nelements2-1
    do n1 = 0, nelements1-1

      do k2 = 0, nelements2-1
        contrib = exp( (two_pi*real(k2*n2,dp)/real(nelements2,dp)) * cmplx_i )

        do k1 = 0, nelements1-1
          coutput(n1,n2) = coutput(n1,n2) + rinput(k1,k2) &
          &                    * contrib * exp( (two_pi*real(k1*n1,dp)/real(nelements1,dp)) * cmplx_i )
        end do !k1
      end do !k2

    end do !n1
  end do !n2
end subroutine dft_forward_2d

subroutine dft_backward_1d(cinput, routput)
  use io, only: io_err
  implicit none
  complex(kind=dp), dimension(0:), intent(in)   ::  cinput
  real(kind=dp),    dimension(0:), intent(out)  ::  routput
  ! local vars:
  complex(kind=dp)  ::  coutput
  integer           ::  n, k, nelements

  ! computes the 1D inverse DFT (see numerical recipes)

  if (size(cinput,1) .ne. size(routput,1)) call io_err("dft_backward_1d: Size of two arrays should match")

  nelements = size(cinput,1)

  do k = 0, nelements-1
    coutput = cmplx(0.0_dp, 0.0_dp, dp)

    do n = 0, nelements-1
      coutput = coutput + cinput(n) * exp( (-two_pi*real(k*n,dp)/real(nelements,dp)) * cmplx_i )
    end do !n

    routput(k) = real(coutput,dp)
  end do !k
  routput = routput/real(nelements,dp)
end subroutine dft_backward_1d

subroutine dft_backward_2d(cinput, routput)
  use io, only: io_err
  implicit none
  complex(kind=dp), dimension(0:,0:), intent(in)  ::  cinput
  real(kind=dp),    dimension(0:,0:), intent(out) ::  routput
  ! local vars:
  complex(kind=dp)      ::  coutput, contrib
  integer               ::  n1, n2, k1, k2, nelements1, nelements2

  ! computes the 2D inverse DFT (see numerical recipes)
  ! could do this with nested 1D transforms (to save code repetition) but clearer to have it all in one routine

  if ((size(cinput,1) .ne. size(routput,1)) .or. &
  &   (size(cinput,2) .ne. size(routput,2))) call io_err("dft_backward_2d: Size of two arrays should match")

  nelements1 = size(cinput,1)
  nelements2 = size(cinput,2)

  do k2 = 0, nelements2-1
    do k1 = 0, nelements1-1
      coutput = cmplx(0.0_dp, 0.0_dp, dp)

      do n2 = 0, nelements2-1
        contrib = exp( (-two_pi*real(k2*n2,dp)/real(nelements2,dp)) * cmplx_i )

        do n1 = 0, nelements1-1
          coutput = coutput + cinput(n1,n2) &
          &                    * contrib * exp( (-two_pi*real(k1*n1,dp)/real(nelements1,dp)) * cmplx_i )
        end do !n1
      end do !n2
      routput(k1,k2) = real(coutput,dp)

    end do !k1
  end do !k2
  routput(:,:) = routput(:,:)/real(nelements1*nelements2,dp)
end subroutine dft_backward_2d

! wrapper routines (automatically pass correct slice of array)
subroutine fourier_interpolation_potential_1d(interp, pos, routput, rgrad)
  use io, only: io_err
  implicit none
  type(interp_type),            intent(in)  ::  interp
  real(kind=dp),                intent(in)  ::  pos
  real(kind=dp),                intent(out) ::  routput
  real(kind=dp),      optional, intent(out) ::  rgrad

  if ((interp%ndims .ne. 1) .or. (.not. interp%ready)) then
    call io_err("fourier_interpolation_potential_1d: interp type does not contain 1D data/has not been transformed")
  end if

  if (present(rgrad)) then
    call fourier_interp_pot_1d(interp%fourier_coeffs(:,0), pos, routput, rgrad)
  else
    call fourier_interp_pot_1d(interp%fourier_coeffs(:,0), pos, routput)
  end if
end subroutine fourier_interpolation_potential_1d

subroutine fourier_interpolation_potential_2d(interp, pos, routput, rgrad)
  use io, only: io_err
  implicit none
  type(interp_type),                          intent(in)  ::  interp
  real(kind=dp),      dimension(2),           intent(in)  ::  pos
  real(kind=dp),                              intent(out) ::  routput
  real(kind=dp),      dimension(2), optional, intent(out) ::  rgrad

  if ((interp%ndims .ne. 2) .or. (.not. interp%ready)) then
    call io_err("fourier_interpolation_potential_2d: interp type does not contain 2D data/has not been transformed")
  end if

  if (present(rgrad)) then
    call fourier_interp_pot_2d(interp%fourier_coeffs, pos, routput, rgrad)
  else
    call fourier_interp_pot_2d(interp%fourier_coeffs, pos, routput)
  end if
end subroutine fourier_interpolation_potential_2d

! 'short name' routines are lower level... called by wrapper routines
subroutine fourier_interp_pot_1d(cinput, pos, routput, rgrad)
  implicit none
  complex(kind=dp), dimension(0:),  intent(in)  ::  cinput
  real(kind=dp),                    intent(in)  ::  pos
  real(kind=dp),                    intent(out) ::  routput
  real(kind=dp),    optional,       intent(out) ::  rgrad
  ! local vars:
  complex(kind=dp)  ::  cgrad
  complex(kind=dp)  ::  component, coutput
  integer           ::  n, nelements

  ! outputs inverse fourier transform of data set interpolated at a pos
  nelements = size(cinput,1)

  coutput = cmplx(0.0_dp, 0.0_dp, dp)
  cgrad = cmplx(0.0_dp, 0.0_dp, dp)

  ! first half of n
  do n = 0, nelements/2
    component = cinput(n)*exp(-two_pi*real(n,dp)*pos*cmplx_i)
    coutput = coutput + component
    cgrad = cgrad + component*real(n,dp)
  end do

  ! second half of n
  do n = nelements/2+1, nelements-1
    component = cinput(n)*exp(-two_pi*real(n-nelements,dp)*pos*cmplx_i)
    coutput = coutput + component
    cgrad = cgrad + component*real(n-nelements,dp)
  end do

  ! only do the rest of the work with cgrad if we need to
  if (present(rgrad)) then
    cgrad = cgrad*(-cmplx_i)
    rgrad = two_pi*real(cgrad,dp)/real(nelements,dp)
  end if

  routput = real(coutput,dp)/real(nelements,dp)
end subroutine fourier_interp_pot_1d

subroutine fourier_interp_pot_2d(cinput, pos, routput, rgrad)
  implicit none
  complex(kind=dp), dimension(0:,0:),           intent(in)  ::  cinput
  real(kind=dp),    dimension(2),               intent(in)  ::  pos
  real(kind=dp),                                intent(out) ::  routput
  real(kind=dp),    dimension(2),     optional, intent(out) ::  rgrad
  ! local vars:
  complex(kind=dp), dimension(2)  ::  cgrad
  complex(kind=dp)                ::  contrib
  complex(kind=dp)                ::  component, coutput
  integer   ::  n1, n2, nelements1, nelements2

  ! outputs inverse fourier transform of data set interpolated at a pos
  nelements1 = size(cinput,1)
  nelements2 = size(cinput,2)

  coutput = cmplx(0.0_dp, 0.0_dp, dp)
  cgrad = cmplx(0.0_dp, 0.0_dp, dp)

  ! first half of n2
  do n2 = 0, nelements2/2

    contrib = exp(-two_pi*real(n2,dp)*pos(2)*cmplx_i)

    ! first half of n1
    do n1 = 0, nelements1/2
      component = cinput(n1,n2)*exp(-two_pi*real(n1,dp)*pos(1)*cmplx_i)*contrib
      coutput = coutput + component
      cgrad(1) = cgrad(1) + component*real(n1,dp)
      cgrad(2) = cgrad(2) + component*real(n2,dp)
    end do !n1

    ! second half of n2
    do n1 = nelements1/2+1, nelements1-1
      component = cinput(n1,n2)*exp(-two_pi*real(n1-nelements1,dp)*pos(1)*cmplx_i)*contrib
      coutput = coutput + component
      cgrad(1) = cgrad(1) + component*real(n1-nelements1,dp)
      cgrad(2) = cgrad(2) + component*real(n2,dp)
    end do !n1
  end do !n2

  ! second half of n2
  do n2 = nelements2/2+1, nelements2-1

    contrib = exp(-two_pi*real(n2-nelements2,dp)*pos(2)*cmplx_i)

    ! first half of n1
    do n1 = 0, nelements1/2
      component = cinput(n1,n2)*exp(-two_pi*real(n1,dp)*pos(1)*cmplx_i)*contrib
      coutput = coutput + component
      cgrad(1) = cgrad(1) + component*real(n1,dp)
      cgrad(2) = cgrad(2) + component*real(n2-nelements2,dp)
    end do !n1

    ! second half of n2
    do n1 = nelements1/2+1, nelements1-1
      component = cinput(n1,n2)*exp(-two_pi*real(n1-nelements1,dp)*pos(1)*cmplx_i)*contrib
      coutput = coutput + component
      cgrad(1) = cgrad(1) + component*real(n1-nelements1,dp)
      cgrad(2) = cgrad(2) + component*real(n2-nelements2,dp)
    end do !n1
  end do !n2

  ! only do the rest of the work with cgrad if we need to
  if (present(rgrad)) then
    cgrad(:) = cgrad(:)*(-cmplx_i)
    rgrad(:) = two_pi*real(cgrad,dp)/real(nelements2*nelements1,dp)
  end if

  routput = real(coutput,dp)/real(nelements2*nelements1,dp)
end subroutine fourier_interp_pot_2d

end module fourier_interpolation


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   mtn : Homoclinic bifurcations in M. Scheffer's preditor-prey model
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION DEM,PSIZ,PSIF,PSIZU1,PSIFU2

      DEM=U(2)**2+PAR(4)**2
      PSIZ=0.4D0*U(1)/(0.6D0+U(1))
      PSIF=PAR(2)*U(2)**2/DEM
      PSIZU1=0.4D0*((1/(0.6D0+U(1)))- (U(1)/((0.6D0+U(1))**2)))
      PSIFU2=2*PAR(2)*( (U(2)/DEM) -(U(2)**3/(DEM**2) ))

      F(1)=0.5D0*U(1)*(1.0D0-U(1)/PAR(1))-U(2)*PSIZ+PAR(3)*PAR(1)
      F(2)=0.6D0*PSIZ*U(2)-0.15D0*U(2)-PSIF

      IF(IJAC.EQ.0)RETURN

        DFDU(1,1)=0.5D0-U(1)/PAR(1) -U(2)*PSIZU1
        DFDU(1,2)=-PSIZ

        DFDU(2,1)=0.6D0*PSIZU1*U(2)
        DFDU(2,2)=0.6D0*PSIZ-0.15D0-PSIFU2

      IF(IJAC.EQ.1)RETURN

        DFDP(1,1)=0.5D0*(U(1)/PAR(1))**2+PAR(3)
        DFDP(2,1)=0.d0

        DFDP(1,2)=0.0d0
        DFDP(2,2)=-U(2)**2/DEM

        DFDP(1,3)=PAR(1)
        DFDP(2,3)=0.d0

        DFDP(1,4)=0.0d0
        DFDP(2,4)=2*PAR(4)*PAR(2)*U(2)**2/DEM**2

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ----------------

! Sets parameter values for homoclinic bifurcation analysis (IPS=9).

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

!----------------------------------------------------------------------
! Problem parameters (only PAR(1-9) are available to the user) :
!     PAR(11) is the trunction interval or `PERIOD'

        PAR(1) = 6.0D0           ! K
        PAR(2) = 0.06729762D0    ! GF
        PAR(3) = 0.01D0          ! D
        PAR(4) = 0.5D0           ! HZ
        PAR(11)= 1046.178D0      ! truncated time interval
!----------------------------------------------------------------------
! Since IEQUIB>0 put the equilibrium in PAR(11+i), i=1,...,NDIM :
        PAR(12) = 5.738626D0
        PAR(13) = 0.5108401D0
!----------------------------------------------------------------------

      END SUBROUTINE STPNT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT


      INTEGER FUNCTION ICEIL( INUM, IDENOM )
*
*  -- ScaLAPACK tools routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IDENOM, INUM
*     ..
*
*  Purpose
*  =======
*
*  ICEIL returns the ceiling of the division of two integers.
*
*  Arguments
*  =========
*
*  INUM     (local input) INTEGER
*           The numerator,
*
*  IDENOM   (local input) INTEGER
*           and the denominator of the fraction to be evaluated.
*
*  =====================================================================
*
*     .. Executable Statements ..
*
      ICEIL = (INUM+IDENOM-1) / IDENOM
*
      RETURN
*
*     End of ICEIL
*
      END


program fortrantest
  use, intrinsic :: iso_c_binding
  use highs_fortran_api
  implicit none

  ! This illustrates the use of Highs_lpCall, the simple F90 interface to
  ! HiGHS. It's designed to solve the general LP problem
  !
  ! Min c^Tx subject to L <= Ax <= U; l <= x <= u
  !
  ! where A is a matrix with m rows and n columns
  !
  ! The scalar n is numcol
  ! The scalar m is numrow
  !
  ! The vector c is colcost
  ! The vector l is collower
  ! The vector u is colupper
  ! The vector L is rowlower
  ! The vector U is rowupper
  !
  ! The matrix A is represented in packed column-wise form: only its
  ! nonzeros are stored
  !
  ! * The number of nonzeros in A is numnz
  !
  ! * The row indices of the nonnzeros in A are stored column-by-column
  ! in aindex
  !
  ! * The values of the nonnzeros in A are stored column-by-column in
  ! avalue
  !
  ! * The position in aindex/avalue of the index/value of the first
  ! nonzero in each column is stored in astart
  !
  ! Note that astart[0] must be zero
  !
  ! After a successful call to Highs_lpCall, the primal and dual
  ! solution, and the simplex basis are returned as follows
  !
  ! The vector x is colvalue
  ! The vector Ax is rowvalue
  ! The vector of dual values for the variables x is coldual
  ! The vector of dual values for the variables Ax is rowdual
  ! The basic/nonbasic status of the variables x is colbasisstatus
  ! The basic/nonbasic status of the variables Ax is rowbasisstatus
  !
  ! The status of the solution obtained is modelstatus
  !
  ! To solve maximization problems, the values in c must be negated
  !
  ! The use of Highs_lpCall is illustrated for the LP/MIP example
  !
  ! Min    f  = 2x_0 + 3x_1
  ! s.t.                x_1 <= 6
  !       10 <=  x_0 + 2x_1 <= 14
  !        8 <= 2x_0 +  x_1
  ! 0 <= x_0 <= 3; 1 <= x_1
  integer ( c_int ), parameter :: numcol = 2
  integer ( c_int ), parameter :: numrow = 3
  integer ( c_int ), parameter :: numnz = 5
  integer ( c_int ), parameter :: aformat_colwise = 1
  integer ( c_int ), parameter :: sense = 1
  real ( c_double ), parameter :: offset = 0

  real ( c_double ) colcost(numcol)
  real ( c_double ) collower(numcol)
  real ( c_double ) colupper(numcol)
  real ( c_double ) rowlower(numrow)
  real ( c_double ) rowupper(numrow)
  integer ( c_int ) astart(numcol)
  integer ( c_int ) aindex(numnz)
  real ( c_double ) avalue(numnz)

  real ( c_double ) colvalue(numcol)
  real ( c_double ) coldual(numcol)
  real ( c_double ) rowvalue(numrow)
  real ( c_double ) rowdual(numrow)
  integer ( c_int ) colbasisstatus(numcol)
  integer ( c_int ) rowbasisstatus(numrow)
  integer modelstatus
  integer runstatus
  integer ( c_int ), parameter :: modelstatus_optimal = 7
  integer ( c_int ), parameter :: runstatus_error = -1
  integer ( c_int ), parameter :: runstatus_ok = 0
  integer ( c_int ), parameter :: runstatus_warning = -1
  ! For the full API test
  type ( c_ptr ) :: highs

  ! For the row-wise matrix
  integer ( c_int ) arstart(numrow)
  integer ( c_int ) arindex(numnz)
  real ( c_double ) arvalue(numnz)

  real, parameter :: inf = 1e30
  integer col, row, el
  integer from_el, to_el
  integer iteration_count, primal_solution_status, dual_solution_status
  double precision objective_function_value
  double precision objective_error
  integer option_type
  integer dummy_info

  integer alt_sense
  integer scale_strategy

  integer, parameter :: default_scale_strategy = 2
  integer, parameter :: new_scale_strategy = 3
  double precision, parameter ::  dual_tolerance = 1d-6
  logical ( c_bool ) write_solution_to_file
  logical ( c_bool ) write_solution_pretty

  double precision, pointer :: double_null(:)
  integer, pointer :: integer_null(:)
  character( c_char ) :: file_name(7)

  ! Illustrate the solution of a QP
  !
  ! minimize -x_2 - 3x_3 + (1/2)(2x_1^2 - 2x_1x_3 + 0.2x_2^2 + 2x_3^2)
  !
  ! subject to x_1 + x_3 <= 2; x>=0
  !
  ! Solution x_1 = 0.5; x_2 = 5.0; x_3 = 1.5
  integer ( c_int ), parameter :: qp_numcol = 3
  integer ( c_int ), parameter :: qp_numrow = 1
  integer ( c_int ), parameter :: qp_numnz = 2
  integer ( c_int ), parameter :: qp_hessian_numnz = 4
  integer ( c_int ), parameter :: qformat_triangular = 1

  real ( c_double ) qp_colcost(qp_numcol)
  real ( c_double ) qp_collower(qp_numcol)
  real ( c_double ) qp_colupper(qp_numcol)
  real ( c_double ) qp_rowlower(qp_numrow)
  real ( c_double ) qp_rowupper(qp_numrow)
  integer ( c_int ) qp_astart(qp_numcol)
  integer ( c_int ) qp_aindex(qp_numnz)
  real ( c_double ) qp_avalue(qp_numnz)
  integer ( c_int ) qp_qstart(qp_numcol)
  integer ( c_int ) qp_qindex(qp_hessian_numnz)
  real ( c_double ) qp_qvalue(qp_hessian_numnz)

  real ( c_double ) qp_sol(qp_numcol)
  real ( c_double ) qp_colvalue(qp_numcol)
  real ( c_double ) qp_coldual(qp_numcol)
  real ( c_double ) qp_rowvalue(qp_numrow)
  real ( c_double ) qp_rowdual(qp_numrow)
  integer ( c_int ) qp_colbasisstatus(qp_numcol)
  integer ( c_int ) qp_rowbasisstatus(qp_numrow)
  integer qp_modelstatus
  integer qp_runstatus
  logical, parameter :: no_highs_logging = .TRUE.

  logical ( c_bool ), parameter :: logical_false = .false.
  logical ( c_bool ), parameter :: logical_true = .true.

  ! Set up the LP/MIP example
  colcost(1) = 2
  colcost(2) = 3

  collower(1) = 0
  collower(2) = 1

  colupper(1) = 3
  colupper(2) = inf

  rowlower(1) = -inf
  rowlower(2) = 10.0
  rowlower(3) = 8.0

  rowupper(1) = 6.0
  rowupper(2) = 14.0
  rowupper(3) = inf

  astart(1) = 0
  astart(2) = 2

  aindex(1) = 1
  aindex(2) = 2
  aindex(3) = 0
  aindex(4) = 1
  aindex(5) = 2

  avalue(1) = 1
  avalue(2) = 2
  avalue(3) = 1
  avalue(4) = 2
  avalue(5) = 1

  ! Define the constraint matrix row-wise, as it is added to the LP with the rows
  arstart(1) = 0
  arstart(2) = 1
  arstart(3) = 3
  arindex(1) = 1
  arindex(2) = 0
  arindex(3) = 1
  arindex(4) = 0
  arindex(5) = 1
  arvalue(1) = 1
  arvalue(2) = 1
  arvalue(3) = 2
  arvalue(4) = 2
  arvalue(5) = 1

  qp_sol(1) = 0.5
  qp_sol(2) = 5.0
  qp_sol(3) = 1.5

  !================================================================================
  ! Illustrate use of Highs_lpCall to solve a given LP
  print*, "*********"
  print*, "Section 1"
  print*, "*********"
  runstatus = Highs_lpCall( numcol, numrow, numnz,&
       aformat_colwise, sense, offset, &
       colcost, collower, colupper, rowlower, rowupper,&
       astart, aindex, avalue,&
       colvalue, coldual, rowvalue, rowdual,&
       colbasisstatus, rowbasisstatus, modelstatus)

  if (runstatus .ne. runstatus_ok) then
     write(*, '(a, i1, a, i2)')'Highs_lpCall run status is ', runstatus, ' not ', runstatus_ok
     stop
  endif
  write(*, '(a, i1, a, i2)')'Run status = ', runstatus, '; Model status = ', modelstatus

  if (modelstatus .eq. modelstatus_optimal) then
     objective_function_value = 0
     ! Report the column primal and dual values, and basis status
     do col = 1, numcol
        write(*, '(a, i1, a, f10.4, a, f10.4, a, i2)') &
             'Col', col, ' = ', colvalue(col), &
             '; dual = ', coldual(col), &
             '; status = ', colbasisstatus(col)
        objective_function_value = objective_function_value + colvalue(col)*colcost(col)
     enddo
     ! Report the row primal and dual values, and basis status
     do row = 1, numrow
        write(*, '(a, i1, a, f10.4, a, f10.4, a, i2)') &
             'Row', row, ' = ', rowvalue(row), &
             '; dual = ', rowdual(row), &
             '; status = ', rowbasisstatus(row)
     enddo
     write(*, '(a, f10.4)')'Optimal objective value = ', objective_function_value
  endif

  ! Illustrate use of Highs_create() to create a pointer to an
  ! instance of the Highs class, then Highs_passLp to pass LP to
  ! HiGHS, and Highs_run to solve it
  highs = Highs_create()
  if (no_highs_logging) then
     runstatus = Highs_setBoolOptionValue(highs, "output_flag"//C_NULL_CHAR, logical_false)
  endif

  runstatus = Highs_passLp(highs, numcol, numrow, numnz, aformat_colwise, &
  sense, offset, colcost, collower, colupper, rowlower, rowupper, &
  astart, aindex, avalue)
  runstatus = Highs_run(highs)
  modelstatus = Highs_getModelStatus(highs);
  print*, "modelstatus = ", modelstatus
  call assert(runstatus .eq. runstatus_ok, "Highs_run runstatus")
  call assert(modelstatus .eq. modelstatus_optimal, "Highs_run modelstatus optimal")
  write(*, '(a, i1, a, i2)')'Run status = ', runstatus, '; Model status = ', modelstatus
  runstatus = Highs_getDoubleInfoValue(highs, "objective_function_value"//C_NULL_CHAR, objective_function_value);
  runstatus = Highs_getIntInfoValue(highs, "simplex_iteration_count"//C_NULL_CHAR, iteration_count);
  write(*, '(a, f10.4, a, i6)')"Objective value = ", objective_function_value, "; Iteration count = ", iteration_count

  call Highs_destroy(highs)
  !================================================================================
  ! Illustrate use of Highs_addCols and Highs_addRows to build model,
  ! and then Highs_changeObjectiveSense to switch to maximization
  print*, "*********"
  print*, "Section 2"
  print*, "*********"
  highs = Highs_create()
  if (no_highs_logging) then
     runstatus = Highs_setBoolOptionValue(highs, "output_flag"//C_NULL_CHAR, logical_false)
  endif
  ! Create double and integer values equal to NULL pointer
  call C_F_POINTER(C_NULL_PTR, double_null, [0])
  call C_F_POINTER(C_NULL_PTR, integer_null, [0])

  ! Add two columns to the empty LP, but no matrix. After numnz=0, can
  ! just pass arrays rather than NULL
  runstatus = Highs_addCols(highs, numcol, colcost, collower, colupper, 0, integer_null, integer_null, double_null);
  ! Add three rows to the 2-column LP
  runstatus = Highs_addRows(highs, numrow, rowlower, rowupper, numnz, arstart, arindex, arvalue)

  runstatus = Highs_getObjectiveSense(highs, alt_sense);
  write(*, '(a, i2)')"LP problem has objective sense = ", alt_sense
  call assert(alt_sense .eq. sense, "Objective sense")

  alt_sense = -1 * alt_sense
  runstatus = Highs_changeObjectiveSense(highs, alt_sense);
  runstatus = Highs_getObjectiveSense(highs, alt_sense);
  call assert(alt_sense .eq. -1, "Changed Objective sense")

  ! Get and set option values
  runstatus = Highs_getIntOptionValue(highs, "simplex_scale_strategy"//C_NULL_CHAR, scale_strategy);
  call assert(scale_strategy .eq. default_scale_strategy,&
       "scale_strategy .eq. default_scale_strategy")
  runstatus = Highs_setIntOptionValue(highs, "simplex_scale_strategy"//C_NULL_CHAR, new_scale_strategy)
  runstatus = Highs_getIntOptionValue(highs, "simplex_scale_strategy"//C_NULL_CHAR, scale_strategy);
  call assert(scale_strategy .eq. new_scale_strategy,&
       "scale_strategy .eq. new_scale_strategy")

  runstatus = Highs_setDoubleOptionValue(highs, "primal_feasibility_tolerance"//C_NULL_CHAR, 1d-6);
  call assert(runstatus .eq. runstatus_ok, "setDoubleOptionValue runstatus")
  runstatus = Highs_setDoubleOptionValue(highs, "dual_feasibility_tolerance"//C_NULL_CHAR, dual_tolerance);
  call assert(runstatus .eq. runstatus_ok, "setDoubleOptionValue runstatus")

  ! There are some functions to check what type of option value you should provide.
  runstatus = Highs_getOptionType(highs, "simplex_scale_strategy"//C_NULL_CHAR, option_type);
  call assert(runstatus .eq. runstatus_ok, "getOptionType runstatus = 0")
  call assert(option_type .eq. 1, "getOptionType option_type")
  ! This is what happens if an invalid name is passed
  runstatus = Highs_getOptionType(highs, "bad_option"//C_NULL_CHAR, option_type)
  call assert(runstatus .eq. runstatus_error, "getOptionType runstatus")

  ! Suppress HiGHS output
  print*, "Suppressing all HiGHS output"
  runstatus = Highs_setBoolOptionValue(highs, "output_flag"//C_NULL_CHAR, logical_false)
  ! Solve the LP
  runstatus = Highs_run(highs);
  ! Get the model status
  modelstatus = Highs_getModelStatus(highs);
  write(*, '(a, i1, a, i2)')'Run status = ', runstatus, '; Model status = ', modelstatus

  ! Get solution data
  runstatus = Highs_getDoubleInfoValue(highs, "objective_function_value"//C_NULL_CHAR, objective_function_value);
  runstatus = Highs_getIntInfoValue(highs, "simplex_iteration_count"//C_NULL_CHAR, iteration_count);
  runstatus = Highs_getIntInfoValue(highs, "primal_solution_status"//C_NULL_CHAR, primal_solution_status);
  runstatus = Highs_getIntInfoValue(highs, "dual_solution_status"//C_NULL_CHAR, dual_solution_status);
  ! This is what happens if an invalid name is passed
  runstatus = Highs_getIntInfoValue(highs, "bad_info"//C_NULL_CHAR, dummy_info)
  call assert(runstatus .eq. runstatus_error, "getOptionType runstatus")

  write(*, '(a, f10.4, a, i6)')"Objective value = ", objective_function_value, "; Iteration count = ", iteration_count
  print*, "modelstatus = ", modelstatus
  call assert(modelstatus .eq. modelstatus_optimal, "Optimal => modelstatus = modelstatus_optimal")
  if (modelstatus .eq. modelstatus_optimal) then
     call assert(primal_solution_status .eq. 2, "Optimal => primal_solution_status = 2")
     call assert(dual_solution_status .eq. 2, "Optimal => dual_solution_status = 2")
     ! Get the primal and dual solution
     runstatus = Highs_getSolution(highs, colvalue, coldual, rowvalue, rowdual);
     ! Get the basis
     runstatus = Highs_getBasis(highs, colbasisstatus, rowbasisstatus);
     ! Report the column primal and dual values, and basis status
     do col = 1, numcol
        write(*, '(a, i1, a, f10.4, a, f10.4, a, i2)') &
             'Col', col, ' = ', colvalue(col), &
             '; dual = ', coldual(col), &
             '; status = ', colbasisstatus(col)
     enddo
     ! Report the row primal and dual values, and basis status
     do row = 1, numrow
        write(*, '(a, i1, a, f10.4, a, f10.4, a, i2)') &
             'Row', row, ' = ', rowvalue(row), &
             '; dual = ', rowdual(row), &
             '; status = ', rowbasisstatus(row)
     enddo
  endif

  ! Write out model as MPS for use later
  runstatus = Highs_writeModel(highs, "F90.mps"//C_NULL_CHAR)
  print*, "runstatus = ", runstatus
  call assert(runstatus .ne. runstatus_warning, "Highs_writeModel runstatus")

  call Highs_destroy(highs)
  !================================================================================
  ! Illustrate use of Highs_readModel to read model, and
  ! Highs_writeSolution to write the solution
  print*, "*********"
  print*, "Section 3"
  print*, "*********"
  highs = Highs_create()
  if (no_highs_logging) then
     runstatus = Highs_setBoolOptionValue(highs, "output_flag"//C_NULL_CHAR, logical_false)
  endif

  ! Read the LP
  runstatus = Highs_readModel(highs, "F90.mps"//C_NULL_CHAR)
  call assert(runstatus .eq. runstatus_ok, "Highs_readModel runstatus")
  ! Solve the LP
  runstatus = Highs_run(highs);
  ! Get the model status
  modelstatus = Highs_getModelStatus(highs);
  write(*, '(a, i1, a, i2)')'Run status = ', runstatus, '; Model status = ', modelstatus
  runstatus = Highs_getDoubleInfoValue(highs, "objective_function_value"//C_NULL_CHAR, objective_function_value);
  runstatus = Highs_getIntInfoValue(highs, "simplex_iteration_count"//C_NULL_CHAR, iteration_count);
  write(*, '(a, f10.4, a, i6)')"Objective value = ", objective_function_value, "; Iteration count = ", iteration_count

  ! Write solution to the screen
  runstatus = Highs_writeSolutionPretty(highs, ""//C_NULL_CHAR)
  call Highs_destroy(highs)

  !================================================================================
  ! Illustrate use of setting bool options and string options
  ! (solution_file) so only run(highs) is required
  print*, "*********"
  print*, "Section 4"
  print*, "*********"
  highs = Highs_create()
  if (no_highs_logging) then
     runstatus = Highs_setBoolOptionValue(highs, "output_flag"//C_NULL_CHAR, logical_false)
  endif

  ! Get and set string options
  runstatus = Highs_getStringOptionValue(highs, "solution_file"//C_NULL_CHAR, file_name)
  print*, "Default solution_file is |", file_name, "|"
  runstatus = Highs_setStringOptionValue(highs, "solution_file"//C_NULL_CHAR, "F90.sol"//C_NULL_CHAR)
  runstatus = Highs_getStringOptionValue(highs, "solution_file"//C_NULL_CHAR, file_name)
  print*, "New solution_file is |", file_name, "|"

! Get and set bool options. NB Cannot pass .true. as it's 4-byte
  runstatus = Highs_getBoolOptionValue(highs, "write_solution_to_file"//C_NULL_CHAR, write_solution_to_file)
  print*, "Default write_solution_to_file = ", write_solution_to_file
  write_solution_to_file = .true.
  runstatus = Highs_setBoolOptionValue(highs, "write_solution_to_file"//C_NULL_CHAR, write_solution_to_file)

  runstatus = Highs_getBoolOptionValue(highs, "write_solution_pretty"//C_NULL_CHAR, write_solution_pretty)
  print*, "Default write_solution_pretty = ", write_solution_pretty
  write_solution_pretty = .true.
  runstatus = Highs_setBoolOptionValue(highs, "write_solution_pretty"//C_NULL_CHAR, write_solution_pretty)

  ! Report all the deviations from default options
  runstatus = Highs_writeOptionsDeviations(highs, "OptionsDeviations.set"//C_NULL_CHAR)

  ! Reset all the options
  runstatus = Highs_resetOptions(highs)

  ! Report all the options
  runstatus = Highs_writeOptions(highs, "Options.set"//C_NULL_CHAR)

  if (no_highs_logging) then
     runstatus = Highs_setBoolOptionValue(highs, "output_flag"//C_NULL_CHAR, logical_false)
  endif

  ! Read the LP
  runstatus = Highs_readModel(highs, "F90.mps"//C_NULL_CHAR)
  ! Solve the LP
  runstatus = Highs_run(highs);
  ! Get the model status
  modelstatus = Highs_getModelStatus(highs);
  call assert(modelstatus .eq. modelstatus_optimal, "Highs_run modelstatus optimal")
  write(*, '(a, i1, a, i2)')'Run status = ', runstatus, '; Model status = ', modelstatus
  runstatus = Highs_getDoubleInfoValue(highs, "objective_function_value"//C_NULL_CHAR, objective_function_value);
  runstatus = Highs_getIntInfoValue(highs, "simplex_iteration_count"//C_NULL_CHAR, iteration_count);
  write(*, '(a, f10.4, a, i6)')"Objective value = ", objective_function_value, "; Iteration count = ", iteration_count
  call Highs_destroy(highs)

  !================================================================================
  ! Illustrate use of Highs_qpCall to solve a given QP

  print*, "**********"
  print*, "QP Example"
  print*, "**********"

  qp_colcost(1) = 0
  qp_colcost(2) = -1
  qp_colcost(3) = -3

  qp_collower(1) = 0
  qp_collower(2) = 0
  qp_collower(3) = 0

  qp_colupper(1) = inf
  qp_colupper(2) = inf
  qp_colupper(3) = inf

  qp_rowlower(1) = -inf
  qp_rowupper(1) = 2

  qp_astart(1) = 0
  qp_astart(2) = 1
  qp_astart(3) = 1

  qp_aindex(1) = 0
  qp_aindex(2) = 0

  qp_avalue(1) = 1
  qp_avalue(2) = 1

  qp_qstart(1) = 0
  qp_qstart(2) = 2
  qp_qstart(3) = 3

  qp_qindex(1) = 0
  qp_qindex(2) = 2
  qp_qindex(3) = 1
  qp_qindex(4) = 2

  qp_qvalue(1) = 2.0
  qp_qvalue(2) = -1.0
  qp_qvalue(3) = 0.2
  qp_qvalue(4) = 2.0

  runstatus = Highs_qpCall( qp_numcol, qp_numrow, qp_numnz, qp_hessian_numnz,&
       aformat_colwise, qformat_triangular, sense, offset,&
       qp_colcost, qp_collower, qp_colupper, qp_rowlower, qp_rowupper,&
       qp_astart, qp_aindex, qp_avalue,&
       qp_qstart, qp_qindex, qp_qvalue,&
       qp_colvalue, qp_coldual, qp_rowvalue, qp_rowdual,&
       qp_colbasisstatus, qp_rowbasisstatus, modelstatus)

  if (runstatus .ne. runstatus_ok) then
     write(*, '(a, i1, a, i2)')'Highs_lpCall run status is ', runstatus, ' not ', runstatus_ok
     stop
  endif
  write(*, '(a, i1, a, i2)')'Run status = ', runstatus, '; Model status = ', modelstatus

  if (modelstatus .eq. modelstatus_optimal) then
     objective_function_value = 0
     ! Report the column primal and dual values, and basis status
     do col = 1, qp_numcol
       write(*, '(a, i1, a, f10.4, a, f10.4, a, i2)') &
             'Col', col, ' = ', qp_colvalue(col), &
             '; dual = ', qp_coldual(col)
     call assert(abs(qp_colvalue(col)-qp_sol(col)) .le. 1e-4, "Solution error")
     enddo
     ! Report the row primal and dual values, and basis status
     do row = 1, qp_numrow
        write(*, '(a, i1, a, f10.4, a, f10.4, a, i2)') &
             'Row', row, ' = ', qp_rowvalue(row), &
             '; dual = ', qp_rowdual(row)
     enddo
     do col = 1, qp_numcol
       objective_function_value = objective_function_value + qp_colvalue(col)*qp_colcost(col)
     enddo
     do col = 1, qp_numcol
        from_el = qp_qstart(col)
        if (col < qp_numcol) then
           to_el = qp_qstart(col+1)-1
        else
           to_el = qp_hessian_numnz
        endif
        objective_function_value = &
             objective_function_value + 0.5 * qp_colvalue(col) * qp_qvalue(from_el+1) * qp_colvalue(col)
        do el = from_el+1, to_el
           row = qp_qindex(el+1)+1
           objective_function_value = &
                objective_function_value + qp_colvalue(col) * qp_qvalue(el+1) * qp_colvalue(row)
        enddo
     enddo
     write(*, '(a, f10.4)')'Optimal objective value = ', objective_function_value
     objective_error = abs(objective_function_value+5.25)
     call assert(objective_error .le. 1e-4, "Objective error")
  endif

end program fortrantest

subroutine assert ( logic, message)
  logical logic
  character*(*) message
  if (.not.logic) then
     write(*, '(a, a)')'assert fail for ', message
     stop
  endif
end subroutine assert


C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C--C O N S T I T U T I V E  M A T E R I A L S  S U B R O U T I N E S---C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE UMAT                                                  C
C     UMAT.for   Classical Isotropic Elasticity                        C
C     UNIVERSIDAD EAFIT                                                C
C     2011                                                             C
C     CANNOT BE USED FOR PLANE STRESS                                  C
C     NTENS: LENGTH OF STRESS VECTOR                                   C
C     NDI:   NUMBER OF NORMAL STRESS COMPONENTS                        C
C                                                                      C
C     PROPS(1) - E                                                     C
C     PROPS(2) - NU                                                    C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE UMAT(DDSDDE,NDI,PROPS,NPROPS)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
C     DIMENSION DDSDDE(NTENS, NTENS),PROPS(NPROPS)
      DIMENSION DDSDDE(NDI, NDI),PROPS(NPROPS)
C
      PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0, SIX=6.0D0,
     1           ENUMAX=0.4999D0)
C
C**********************************************************************
C     I S O T R O P I C   E L A S T I C I T Y
C     P L A N E  S T R A I N  A N A L Y S I S
C**********************************************************************
C
C     Wave propagation velocities.
C
      VP=PROPS(1)
      VS=PROPS(2)
      RO=PROPS(3)
C
      VPS=VP*VP
      VSS=VS*VS
C
C     Elasticity tensor.

	  DDSDDE(1,1)= VPS
	  DDSDDE(1,2)= VPS-2.0D0*VSS
	  DDSDDE(2,1)= VPS-2.0D0*VSS
	  DDSDDE(2,2)= VPS
	  DDSDDE(3,3)= VSS

	  DDSDDE=DDSDDE*RO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE UMAT3D                                                C
C     UMAT.for   Classical Isotropic Elasticity                        C
C     UNIVERSIDAD EAFIT                                                C
C     2011                                                             C
C     CANNOT BE USED FOR PLANE STRESS                                  C
C     NTENS: LENGTH OF STRESS VECTOR (6 fo 3D problems)                C
C     NDI:   NUMBER OF NORMAL STRESS COMPONENTS (3 for 3D problems)    C
C                                                                      C
C     PROPS(1) - alpha                                                 C
C     PROPS(2) - beta                                                  C
C     PROPS(3) - ro                                                    C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE UMAT3D(DDSDDE,NDI,NTENS,PROPS,NPROPS)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION DDSDDE(NTENS, NTENS),PROPS(NPROPS)
C
      PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0, SIX=6.0D0,
     1           ENUMAX=0.4999D0)
C
C**********************************************************************
C     I S O T R O P I C   E L A S T I C I T Y
C     P L A N E  S T R A I N  A N A L Y S I S
C**********************************************************************
C
C     Wave propagation velocities.
C
      VP=PROPS(1)
      VS=PROPS(2)
      RO=PROPS(3)
C
      VPS=VP*VP
      VSS=VS*VS
C
C     Elasticity tensor.
C
      DO K1=1, NDI
        DO K2=1, NDI
          DDSDDE(K2, K1)=(VPS-2.0D0*VSS)*RO
        END DO
        DDSDDE(K1, K1)=VPS*RO
      END DO
      DO K1=NDI+1, NTENS
        DDSDDE(K1, K1)=VSS*RO
      END DO
C
      RETURN
C
      END
C


!-----------------------------------------------------------------------
!
! Header with QFunctions
!
      include 't531-operator-f.h'
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j,k
      integer stridesu(3),stridesqd(3)
      integer erestrictx,erestrictu,erestrictui
      integer erestrictqi,erestrictlini
      integer bx,bu
      integer qf_setup,qf_diff,qf_diff_lin
      integer op_setup,op_diff,op_diff_lin
      integer qdata,x,a,u,v
      integer nelem,p,q,d
      integer row,col,offset
      parameter(nelem=6)
      parameter(p=3)
      parameter(q=4)
      parameter(d=2)
      integer ndofs,nqpts,nx,ny
      parameter(nx=3)
      parameter(ny=2)
      parameter(ndofs=(nx*2+1)*(ny*2+1))
      parameter(nqpts=nelem*q*q)
      integer indx(nelem*p*p)
      real*8 arrx(d*ndofs),vv(ndofs)
      integer*8 xoffset,voffset

      character arg*32

      external setup,diff,diff_lin

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)

! DoF Coordinates
      do i=0,nx*2
        do j=0,ny*2
          arrx(i+j*(nx*2+1)+0*ndofs+1)=1.d0*i/(2*nx)
          arrx(i+j*(nx*2+1)+1*ndofs+1)=1.d0*j/(2*ny)
        enddo
      enddo
      call ceedvectorcreate(ceed,d*ndofs,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)

! Qdata Vector
      call ceedvectorcreate(ceed,nqpts*d*(d+1)/2,qdata,err)

! Element Setup
      do i=0,nelem-1
        col=mod(i,nx)
        row=i/nx
        offset=col*(p-1)+row*(nx*2+1)*(p-1)
        do j=0,p-1
          do k=0,p-1
            indx(p*(p*i+k)+j+1)=offset+k*(nx*2+1)+j
          enddo
        enddo
      enddo

! Restrictions
      call ceedelemrestrictioncreate(ceed,nelem,p*p,d,ndofs,d*ndofs,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictx,err)

      call ceedelemrestrictioncreate(ceed,nelem,p*p,1,1,ndofs,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictu,err)
      stridesu=[1,q*q,q*q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q*q,1,nqpts,&
     & stridesu,erestrictui,err)

      stridesqd=[1,q*q,q*q*d*(d+1)/2]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q*q,d*(d+1)/2,&
     & d*(d+1)/2*nqpts,stridesqd,erestrictqi,err)

! Bases
      call ceedbasiscreatetensorh1lagrange(ceed,d,d,p,q,ceed_gauss,&
     & bx,err)
      call ceedbasiscreatetensorh1lagrange(ceed,d,1,p,q,ceed_gauss,&
     & bu,err)

! QFunction - setup
      call ceedqfunctioncreateinterior(ceed,1,setup,&
     &SOURCE_DIR&
     &//'t531-operator.h:setup'//char(0),qf_setup,err)
      call ceedqfunctionaddinput(qf_setup,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_setup,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddoutput(qf_setup,'qdata',d*(d+1)/2,ceed_eval_none,err)

! Operator - setup
      call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup,err)
      call ceedoperatorsetfield(op_setup,'dx',erestrictx,&
     & bx,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup,'_weight',ceed_elemrestriction_none,&
     & bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup,'qdata',erestrictqi,&
     & ceed_basis_collocated,ceed_vector_active,err)

! Apply Setup Operator
      call ceedoperatorapply(op_setup,x,qdata,ceed_request_immediate,err)

! QFunction - apply
      call ceedqfunctioncreateinterior(ceed,1,diff,&
     &SOURCE_DIR&
     &//'t531-operator.h:diff'//char(0),qf_diff,err)
      call ceedqfunctionaddinput(qf_diff,'du',d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_diff,'qdata',d*(d+1)/2,ceed_eval_none,err)
      call ceedqfunctionaddoutput(qf_diff,'dv',d,ceed_eval_grad,err)

! Operator - apply
      call ceedoperatorcreate(ceed,qf_diff,ceed_qfunction_none,&
     & ceed_qfunction_none,op_diff,err)
      call ceedoperatorsetfield(op_diff,'du',erestrictu,&
     & bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_diff,'qdata',erestrictqi,&
     & ceed_basis_collocated,qdata,err)
      call ceedoperatorsetfield(op_diff,'dv',erestrictu,&
     & bu,ceed_vector_active,err)

! Apply original Poisson Operator
      call ceedvectorcreate(ceed,ndofs,u,err)
      call ceedvectorsetvalue(u,1.d0,err)
      call ceedvectorcreate(ceed,ndofs,v,err)
      call ceedvectorsetvalue(v,0.d0,err)
      call ceedoperatorapply(op_diff,u,v,ceed_request_immediate,err)

! Check Output
      call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err)
      do i=1,ndofs
      if (abs(vv(voffset+i))>1.0d-14) then
! LCOV_EXCL_START
        write(*,*) 'Error: Operator computed v[i] = ',vv(voffset+i),' != 0.0'
! LCOV_EXCL_STOP
      endif
      enddo
      call ceedvectorrestorearrayread(v,vv,voffset,err)

! Assemble QFunction
      call ceedoperatorlinearassembleqfunction(op_diff,a,erestrictlini,&
     & ceed_request_immediate,err)

! QFunction - apply linearized
      call ceedqfunctioncreateinterior(ceed,1,diff_lin,&
     &SOURCE_DIR&
     &//'t531-operator.h:diff_lin'//char(0),qf_diff_lin,err)
      call ceedqfunctionaddinput(qf_diff_lin,'du',d,ceed_eval_grad,err)
      call ceedqfunctionaddinput(qf_diff_lin,'qdata',d*d,ceed_eval_none,err)
      call ceedqfunctionaddoutput(qf_diff_lin,'dv',d,ceed_eval_grad,err)

! Operator - apply linearized
      call ceedoperatorcreate(ceed,qf_diff_lin,ceed_qfunction_none,&
     & ceed_qfunction_none,op_diff_lin,err)
      call ceedoperatorsetfield(op_diff_lin,'du',erestrictu,&
     & bu,ceed_vector_active,err)
      call ceedoperatorsetfield(op_diff_lin,'qdata',erestrictlini,&
     & ceed_basis_collocated,a,err)
      call ceedoperatorsetfield(op_diff_lin,'dv',erestrictu,&
     & bu,ceed_vector_active,err)

! Apply linearized Poisson Operator
      call ceedvectorsetvalue(v,0.d0,err)
      call ceedoperatorapply(op_diff_lin,u,v,ceed_request_immediate,err)

! Check Output
      call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err)
      do i=1,ndofs
      if (abs(vv(voffset+i))>1.0d-14) then
! LCOV_EXCL_START
        write(*,*) 'Error: Linearized operator computed v[i] = ',vv(voffset+i),&
     &   ' != 0.0'
! LCOV_EXCL_STOP
      endif
      enddo
      call ceedvectorrestorearrayread(v,vv,voffset,err)

! Cleanup
      call ceedqfunctiondestroy(qf_setup,err)
      call ceedqfunctiondestroy(qf_diff,err)
      call ceedqfunctiondestroy(qf_diff_lin,err)
      call ceedoperatordestroy(op_setup,err)
      call ceedoperatordestroy(op_diff,err)
      call ceedoperatordestroy(op_diff_lin,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceedelemrestrictiondestroy(erestrictqi,err)
      call ceedelemrestrictiondestroy(erestrictlini,err)
      call ceedbasisdestroy(bu,err)
      call ceedbasisdestroy(bx,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(a,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedvectordestroy(qdata,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------