	SUBROUTINE  ST_CRND  ( string, value, ndec, iret )
C************************************************************************
C* ST_CRND								*
C*									*
C* This subroutine converts a character string to a real number.  If	*
C* the conversion fails, RMISSD is returned.				*
C*									*
C* ST_CRND  ( STRING, VALUE, NDEC, IRET ) 				*
C*									*
C* Input parameters: 							*
C*	STRING		CHAR*		String				*
C*									*
C* Output parameters:							*
C*	VALUE		REAL		Real number			*
C*	NDEC		INTEGER		Number of decimal places	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -2 = conversion error 		*
C**									*
C* Log:									*
C* S. Maxwell/GSC	 4/97 	Copied from ST_CRNM			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	string
C*
	CHARACTER	sss*24, ttt*4, c*1
	LOGICAL		good, plus, before
C------------------------------------------------------------------------
	iret = -2
	value = RMISSD
C
C*	Remove blanks from string.
C
	CALL ST_RMBL  ( string, sss, lens, ier )
C
C*	Check for + or - in first character.
C
	IF  ( sss (1:1) .eq. '+' )  THEN
	    ibeg = 2
	    plus = .true.
	  ELSE IF  ( sss (1:1) .eq. '-' )  THEN
	    ibeg = 2
	    plus = .false.
	  ELSE
	    ibeg = 1
	    plus = .true.
	END IF
	IF  ( ibeg .gt. lens )  RETURN
C
C*	Now loop through all characters and turn into integers corresponding
C*	to values before and after decimal point and for exponent.
C
	ival0  = ICHAR ( '0' )
	ibefor = 0
	iafter = 0
	nafter = 0
	iexp   = 0
	good   = .true.
	i      = ibeg
	before = .true.
	DO  WHILE  ( good .and. ( i .le. lens ) )
	    c     = sss (i:i)
	    IF  ( ( c .ge. '0' ) .and. ( c .le. '9' ) )  THEN
		ivalc = ICHAR (c) - ival0
		IF  ( before )  THEN
		    ibefor = ibefor * 10 + ivalc
		  ELSE
		    iafter = iafter * 10 + ivalc
		    nafter = nafter + 1
		END IF
	      ELSE IF  ( c .eq. '.' )  THEN
		IF  ( before )  THEN
		    before = .false.
		  ELSE
		    good   = .false.
		END IF
	      ELSE IF  ( ( ( c .eq. 'E' ) .or. ( c .eq. 'e' ) )
     +                 .and. lens .ne. 1 )  THEN
		IF  ( i .lt. lens )  THEN
		    ttt = sss ( i+1 : )
		    CALL ST_NUMB  ( ttt, iexp, ier )
		    IF  ( ier .ne. 0 )  good = .false.
		END IF
		i = lens
	      ELSE
		good = .false.
	    END IF
	    i = i + 1
	END DO
C
C*	Compute the value using the three parts.
C
	IF  ( good )  THEN
	    iret = 0
	    value = FLOAT ( ibefor )
	    IF  ( nafter .gt. 0 )  THEN
		value = value + ( FLOAT ( iafter ) / 10. ** nafter )
	    END IF
	    IF  ( iexp .ne. 0 )  THEN
C
C*		If the exponent is greater than 20, set the value
C*		to missing.
C
		IF  ( ABS ( iexp ) .gt. 20 )  THEN
		    value = RMISSD
		    RETURN
		  ELSE
		    value = value * 10. ** iexp
		END IF
	    END IF
	    IF  ( .not. plus )  value = -value
	END IF
C
	ndec = nafter
C*
	RETURN
	END


module probdata_module

!     variables for initialization; see Lee & Koo AIAA Journal 1995
      use amrex_fort_module, only : rt => amrex_real
      real(rt)        , save :: p_ref, r_0, mach, ratio_c, r_circ
      real(rt)        , save :: rho_0, c_0, r_c, circ
      real(rt)        , save :: x_c1, y_c1, x_c2, y_c2

end module probdata_module


PROGRAM SOSIE

  !!----------------------------------------------------------------------
  !!
  !!     SOSIE is Only a Surface Interpolation Environment
  !!     =================================================
  !!
  !!     Version "2.6.4"   June 2016
  !!
  !!
  !!    PURPOSE:
  !!    --------
  !!    * Reads a geophysical field on a given source grid in a netcdf file
  !!
  !!    * Remaps it on a given target grid using either the Akima method or the bilinear or bicubic
  !!      methods in case the source grid is distorded (horizontally)
  !!
  !!    * Writes the remaped field in a netcf file
  !!
  !!
  !!    METHODS:
  !!    --------
  !!      * Horizontal interpolation
  !!          - Akima (1970) method: "A New Method of Interpolation and Smooth Surface Fitting Based
  !!                               on local Procedures, J.of Applied Comput. Math., 17, 589-602."
  !!          - Standard bilinear
  !!          - Bicubic
  !!      * Verical interpolation (for 3D fields)
  !!
  !!
  !!
  !!     AUTHORS:
  !!     -------
  !!     Laurent Brodeau, 2014
  !!     Jean-Michel Brankart, Jean-Marc Molines, Pierre Mathiot
  !!
  !!--------------------------------------------------------------------------

  USE mod_conf     !* important parameters, namelist, arrays, etc...
  USE mod_init     !* important parameters, namelist, arrays, etc...
  USE io_ezcdf     !* routines for netcdf input/output
  USE mod_grids    !* grided-domain module
  USE mod_interp

  IMPLICIT NONE

  CHARACTER(len=800) :: cextinf

  INTEGER    :: &
       &   jt, jte, jct, jcz,  &
       &   idf_o, idf_i, idv_o, idv_i  !: netcdf ID for source/target file

  REAL(4) :: rfct_miss=1.

  !OPEN(UNIT=6, FORM='FORMATTED', RECL=512)  !lolo: problem with Gfortan 4.8...

  WRITE(6,*)''
  WRITE(6,*)'=========================================================='
  WRITE(6,*)'            S  O  S  I  E    version ', trim(csosie_version)
  WRITE(6,*)'=========================================================='
  WRITE(6,*)''

  !! Fecthing command line arguments if any:
  CALL GET_ARGUMENTS()    ! MODUDE mod_init

  !! Reading namelist:
  CALL READ_NMLST(1)      ! MODUDE mod_init

  !! Setting defaults for some logical flags :
  l3d = .FALSE. ; l_int_3d = .FALSE. ; ltime = .TRUE.

  !! Getting source domain and metrics:
  CALL SRC_DOMAIN()       ! MODULE mod_grids
  mask_in_b = mask_in     ! making a backup of the land-sea mask on the source grid

  !! Getting target domain and metrics:
  CALL TRG_DOMAIN()       ! MODULE mod_grids

  !! Just to display some info of the current setting:
  CALL REMINDER()         ! MODUDE mod_init

  IF ( Ntr == 0 ) THEN
     PRINT *, 'PROBLEM: something is wrong => Ntr = 0 !!!'; STOP
  END IF

  IF ( .NOT. lmout) rfct_miss = 0.

  cextinf =                'Horizontal grid read in '//TRIM(cf_x_out)
  IF (l_int_3d) cextinf = TRIM(cextinf)//' / Vertical grid read in '//TRIM(cf_z_out)
  cextinf = TRIM(cextinf)//' / Source field read in '//TRIM(cf_in)
  cextinf = TRIM(cextinf)//' / Interpolation method: '//TRIM(cmethod)

  !!                -------------------------------
  !!                  M A I N   T I M E   L O O P
  !!                -------------------------------

  jct = 0 ;  jcz = 0
  IF ( ltime ) jct = 1
  IF (  l3d  ) jcz = 1

  DO jt = 1, Ntr

     jte = j_start + jt - 1     ! actual time record to extract

     WRITE(*,'(" *** treating record #",i5)') jte

     IF ( .not. l_int_3d ) THEN

        !! ================
        !! 2D INTERPOLATION
        !! ================

        data_in = 0.

        !! Read data 2D field at time jte :
        CALL GETVAR_2D(idf_i, idv_i, cf_in, cv_in, Ntr, jplev*jcz, jte*jct, data_in, jt1=j_start, jt2=j_stop)

        !! In case scale_factor or add_offset :
        IF ((rsf /= 1.).or.(rao /= 0.)) data_in = rsf*data_in + rao

        CALL INTERP_2D()

        !! => data_out for current time step is ready to be written in netcdf file

        !! Print current record into netcdf file
        CALL P2D_T(idf_o, idv_o, Ntr, jt,    &
             &     lon_out_b, lat_out, vt, data_out,    &
             &     cf_out, cv_l_out, cv_p_out, cv_t_out,    &
             &     cv_out, cu_out, cln_out, rfct_miss*REAL(rmaskvalue,4), &
             &     cun_t=cu_t, lpack=lpcknc4, cextrainfo=cextinf)

     ELSE

        !! ================
        !! 3D INTERPOLATION
        !! ================

        data3d_in = 0.

        !! Read data 3D field at time jt :
        CALL GETVAR_3D(idf_i, idv_i, cf_in, cv_in, Ntr, jte*jct, data3d_in, jt1=j_start, jt2=j_stop)

        !! In case scale_factor or add_offset :
        IF ((rsf /= 1.).or.(rao /= 0.)) data3d_in = rsf*data3d_in + rao

        CALL INTERP_3D()

        !! Print current record into netcdf file
        !!  => data3d_out for current time step is ready to be written in netcdf file

        CALL P3D_T(idf_o, idv_o, Ntr, jt, &
             &     lon_out_b, lat_out, depth_out, vt, data3d_out,                &
             &     cf_out, cv_l_out, cv_p_out, cv_z_out_name, cv_t_out, &
             &     cv_out, cu_out, cln_out, rfct_miss*REAL(rmaskvalue,4), &
             &     cun_t=cu_t, lpack=lpcknc4, cextrainfo=cextinf)

     END IF ! .not. l_int_3d

  END DO  ! end of time loop

  CALL TERMINATE() ! deleting and de-allocating arrays...

  PRINT *, ''; PRINT *, TRIM(cf_out), ' is created'; PRINT *, ''

  CLOSE(6)

END PROGRAM SOSIE


function sfhlimit(tlim, sfh)
  ! Deal with all the logic for computing the limits of integration in the
  ! weight calculations.  This should return the input `tlim`, clipped to valid
  ! limits, such that if no SFR occurs between t1 and t2 then sfhlimit(t1, sfh)
  ! = sfhlimit(t2, sfh)
  !
  ! Inputs
  ! ----------
  !
  ! tlim:
  !    The proposed limit of the integration, in log(lookback_time(yrs)).
  !
  ! sfh:
  !    An sfhparams structure containing the relevant special lookback times.
  !
  use sps_vars, only: tiny_logt, SFHPARAMS, SP
  implicit none

  real(SP), intent(in) :: tlim
  type(SFHPARAMS), intent(in) :: sfh

  real(SP) :: sfhlimit

  real(SP) :: tlo, thi

  ! For the simha linear portion, we integrate from sf_trunc to tage or the
  ! zero crossing, whichever is smaller but still greater than sf_trunc.
  ! For everything else we integrate from 0 to tage or sf_trunc, whichever is
  ! smaller but non-zero.
  ! Of course, we are doing this using the lookback time versions of sf_trunc,
  ! the zero crossing time, and 0!!!
  if (sfh%use_simha_limits.eq.1) then
     tlo = sfh%t0
     thi = sfh%tq
  else
     tlo = sfh%tq
     thi = sfh%tage
  endif

  ! Convert to log, taking care of possible zeros.
  tlo = log10(max(tlo, 10**tiny_logt))
  thi = log10(max(thi, 10**tiny_logt))

  ! Finally, clip proposed limit to the upper and lower value
  sfhlimit = MIN(MAX(tlim, tlo), thi)

end function sfhlimit


C NCLFORTSTART
      subroutine evssm (nvar, lssm, cssm, neval, weval, wevec,info,iopt)
      implicit none
                                                  ! input
      integer          nvar, lssm, info, neval, iopt
      double precision cssm(lssm)
                                                  ! output
      double precision weval(neval), wevec(nvar,neval)
C NCLEND
      integer          il  , iu  , mout, ldz, n, nn
     +                ,iwork(5*nvar), ifail(nvar)
      double precision vl  , vu  , abstol, work(8*nvar)
      character*1      jobz, rang, uplo

c .   jobz    = "V"       ; compute eigen{values/vectors}
c .   rang    = "I"       ; compute user specified iL to iU eigenvalues
c .   uplo    = "U"       ; input is lower(L)/upper(U) triangle
c .   vl      = 1d20      ; not used if:  range= "A" or "I"
c .   vu      = 1d20      ; not used
c .   neval   = iu-il+1   ; number of eigenvalues and vectors
c .   abstol  = 0.0       ; this mean use the default tolerance
c .   mout    = 0         ; ouput number of eigenvalues

      jobz    = "V"
      rang    = "I"
      uplo    = "U"

      il      = max(nvar-neval+1,1)
      iu      = nvar

      mout    = -99
      ldz     = nvar

      vl      = 1d20
      vu      = 1d20
      abstol  = 0.0d0

      call dspevx(jobz, rang, uplo, nvar, cssm, vl, vu, il, iu
     +           ,abstol ,mout, weval, wevec, ldz, work, iwork
     +           ,ifail, info)

      if (iopt.eq.0) then

c reverse the order of arrays returned from "dspevx" so
c .   largest eigenvalues/vectors are first.

          do n=1,neval
             work(n) = weval(n)
          end do
          do n=1,neval
             weval(n) = work(neval+1-n)
          end do

          do n=1,nvar
              do nn=1,neval
                 work(nn) = wevec(n,nn)
              end do
              do nn=1,neval
                 wevec(n,nn) = work(neval+1-nn)
              end do
          end do
      end if

      return
      end


!
! Copyright 2020-2022 Fluid Numerics LLC
! Author : Joseph Schoonover (joe@fluidnumerics.com)
! Support : support@fluidnumerics.com
!
! //////////////////////////////////////////////////////////////////////////////////////////////// !
MODULE SELF_ShallowWater

  USE SELF_Metadata
  USE SELF_Mesh
  USE SELF_MappedData
  USE SELF_Model

  TYPE,EXTENDS(Model2D) :: ShallowWater
    !! iVar = 1 ~> u velocity component
    !! iVar = 2 ~> v velocity component
    !! iVar = 3 ~> free surface height
    REAL(prec) :: fCori ! coriolis parameter ( 1/s )
    REAL(prec) :: g     ! gravity ( m/s^2)
    TYPE(MappedScalar2D) :: H ! bottom topography ( m )
    TYPE(MappedVector2D) :: gradH ! bottom topography gradient ( m/m )

    CONTAINS

    ! Overridden Methods
    PROCEDURE :: Init => Init_ShallowWater
    PROCEDURE :: CalculateEntropy => CalculateEntropy_ShallowWater

    PROCEDURE :: PreTendency => PreTendency_ShallowWater

    ! Concretized Methods
    PROCEDURE :: SourceMethod => Source_ShallowWater
    PROCEDURE :: FluxMethod => Flux_ShallowWater
    PROCEDURE :: RiemannSolver => RiemannSolver_ShallowWater
    PROCEDURE :: SetBoundaryCondition => SetBoundaryCondition_ShallowWater

    ! New Methods
    GENERIC :: SetTopography => SetTopographyFromChar_ShallowWater,&
                              SetTopographyFromEqn_ShallowWater
    PROCEDURE,PRIVATE :: SetTopographyFromChar_ShallowWater
    PROCEDURE,PRIVATE :: SetTopographyFromEqn_ShallowWater

  END TYPE ShallowWater

  INTERFACE
    SUBROUTINE SetBoundaryCondition_ShallowWater_gpu_wrapper(solution, extBoundary, nHat, sideInfo, N, nVar, nEl) &
      bind(c,name="SetBoundaryCondition_ShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: solution, extBoundary, nHat, sideInfo
      INTEGER(C_INT),VALUE :: N,nVar,nEl
    END SUBROUTINE SetBoundaryCondition_ShallowWater_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE Source_ShallowWater_gpu_wrapper(source, solution, f, N, nVar, nEl) &
      bind(c,name="Source_ShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: source, solution
      INTEGER(C_INT),VALUE :: N,nVar,nEl
      REAL(c_prec),VALUE :: f
    END SUBROUTINE Source_ShallowWater_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE Flux_ShallowWater_gpu_wrapper(flux, solution, g, H, N, nVar, nEl) &
      bind(c,name="Flux_ShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: flux, solution
      INTEGER(C_INT),VALUE :: N,nVar,nEl
      REAL(c_prec),VALUE :: g, H
    END SUBROUTINE Flux_ShallowWater_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE RiemannSolver_ShallowWater_gpu_wrapper(flux, solution, extBoundary, nHat, nScale, g, H, N, nVar, nEl) &
      bind(c,name="RiemannSolver_ShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: flux, solution, extBoundary, nHat, nScale
      INTEGER(C_INT),VALUE :: N,nVar,nEl
      REAL(c_prec),VALUE :: g, H
    END SUBROUTINE RiemannSolver_ShallowWater_gpu_wrapper
  END INTERFACE

CONTAINS

  SUBROUTINE Init_ShallowWater(this,nvar,mesh,geometry,decomp)
    IMPLICIT NONE
    CLASS(ShallowWater),INTENT(out) :: this
    INTEGER,INTENT(in) :: nvar
    TYPE(Mesh2D),INTENT(in),TARGET :: mesh
    TYPE(SEMQuad),INTENT(in),TARGET :: geometry
    TYPE(MPILayer),INTENT(in),TARGET :: decomp
    ! Local
    INTEGER :: ivar
    CHARACTER(LEN=3) :: ivarChar
    CHARACTER(LEN=25) :: varname
    INTEGER :: nvarloc

    ! Ensure that the number of variables is 3
    ! nvar is unused in this class extension
    nvarloc = 3

    this % decomp => decomp
    this % mesh => mesh
    this % geometry => geometry
    this % gpuAccel = .FALSE.
    this % fluxDivMethod = SELF_CONSERVATIVE_FLUX
    this % g = 1.0_prec
    this % fCori = 0.0_prec

    CALL this % solution % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % H % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % gradH % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % workSol % Init(geometry % x % interp,nVar,this % mesh % nElem)
    CALL this % velocity % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % compVelocity % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % dSdt % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % solutionGradient % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % flux % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % source % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % fluxDivergence % Init(geometry % x % interp,nvarloc,this % mesh % nElem)

    ! First three variables are treated as u, v, eta
    ! Any additional are treated as passive tracers
    CALL this % solution % SetName(1,"Hu")
    CALL this % solution % SetUnits(1,"m^2/s")
    CALL this % solution % SetDescription(1,"x-component of the volume flux")

    CALL this % solution % SetName(2,"Hv")
    CALL this % solution % SetUnits(2,"m^2/s")
    CALL this % solution % SetDescription(2,"y-component of the volume flux")

    CALL this % solution % SetName(3,"H")
    CALL this % solution % SetUnits(3,"m")
    CALL this % solution % SetDescription(3,"Total fluid thickness")

  END SUBROUTINE Init_ShallowWater

  SUBROUTINE CalculateEntropy_ShallowWater(this)
  !! Base method for calculating entropy of a model
  !! Calculates the entropy as the integration of the
  !! squared tracer over the domain
    IMPLICIT NONE
    CLASS(ShallowWater), INTENT(inout) :: this
    ! Local
    INTEGER :: i, j, iVar, iEl
    REAL(prec) :: Jacobian, Hu, Hv, H, b
    REAL(prec) :: wi,wj

    ! TO DO : GPU reduction

    this % entropy = 0.0_prec

    DO iEl = 1, this % geometry % x % nElem
        DO j = 0, this % geometry % x % interp % N
          DO i = 0, this % geometry % x % interp % N

            ! Coordinate mapping Jacobian
            Jacobian = this % geometry % J % interior % hostData(i,j,1,iEl)

            ! Quadrature weights
            wi = this % geometry % x % interp % qWeights % hostData(i)
            wj = this % geometry % x % interp % qWeights % hostData(j)

            ! Solution
            Hu = this % solution % interior % hostData(i,j,1,iEl)
            Hv = this % solution % interior % hostData(i,j,2,iEl)
            H = this % solution % interior % hostData(i,j,3,iEl)
            b = this % H % interior % hostData(i,j,1,iEl)

            this % entropy = this % entropy + ( 0.5_prec*( Hu*Hu/H + Hv*Hv/H ) + &
                                                0.5_prec*this % g*H*H - this % g*H*b )*Jacobian*wi*wj

          ENDDO
        ENDDO
    ENDDO

  END SUBROUTINE CalculateEntropy_ShallowWater

  SUBROUTINE PreTendency_ShallowWater(this)
    !! Calculate the velocity at element interior and element boundaries
    !! PreTendency is a template routine that is used to house any additional calculations
    !! that you want to execute at the beginning of the tendency calculation routine.
    !! This default PreTendency simply returns back to the caller without executing any instructions
    !!
    !! The intention is to provide a method that can be overridden through type-extension, to handle
    !! any steps that need to be executed before proceeding with the usual tendency calculation methods.
    !!
    IMPLICIT NONE
    CLASS(ShallowWater),INTENT(inout) :: this
    !
    INTEGER :: iEl, iSide, j, i
    REAL(prec) :: H

      DO iEl = 1, this % solution % nElem
        DO j = 0, this % solution % interp % N
          DO i = 0, this % solution % interp % N

            H = this % solution % interior % hostData(i,j,3,iEl)

            this % velocity % interior % hostData(1,i,j,1,iEl) = &
                    this % solution % interior % hostData(i,j,1,iEl)/H

            this % velocity % interior % hostData(2,i,j,1,iEl) = &
                    this % solution % interior % hostData(i,j,2,iEl)/H

          ENDDO
        ENDDO
      ENDDO

      DO iEl = 1, this % solution % nElem
        DO iSide = 1, 4
          DO i = 0, this % solution % interp % N

            H = this % solution % boundary % hostData(i,3,iSide,iEl)

            this % velocity % boundary % hostData(1,i,1,iSide,iEl) = &
                    this % solution % boundary % hostData(i,1,iSide,iEl)/H

            this % velocity % boundary % hostData(2,i,1,iSide,iEl) = &
                    this % solution % boundary % hostData(i,2,iSide,iEl)/H
          ENDDO
        ENDDO
      ENDDO

      CALL this % velocity % SideExchange(this % mesh, this % decomp, this % gpuAccel)

  END SUBROUTINE PreTendency_ShallowWater

  SUBROUTINE SetTopographyFromChar_ShallowWater(this, eqnChar)
    IMPLICIT NONE
    CLASS(ShallowWater),INTENT(inout) :: this
    CHARACTER(*),INTENT(in) :: eqnChar

      CALL this % H % SetEquation(1, eqnChar)

      CALL this % H % SetInteriorFromEquation( this % geometry, this % t )

      CALL this % H % BoundaryInterp( gpuAccel = .FALSE. )

      CALL this % H % Gradient( this % geometry, &
                                this % gradH, &
                                selfStrongForm, &
                                .FALSE.)

      IF( this % gpuAccel )THEN
        CALL this % H % UpdateDevice()
      ENDIF

  END SUBROUTINE SetTopographyFromChar_ShallowWater

  SUBROUTINE SetTopographyFromEqn_ShallowWater(this, eqn)
    IMPLICIT NONE
    CLASS(ShallowWater),INTENT(inout) :: this
    TYPE(EquationParser),INTENT(in) :: eqn

      ! Copy the equation parser
      CALL this % H % SetEquation(1, eqn % equation)

      CALL this % H % SetInteriorFromEquation( this % geometry, this % t )

      CALL this % H % BoundaryInterp( gpuAccel = .FALSE. )

      CALL this % H % Gradient( this % geometry, &
                                this % gradH, &
                                selfStrongForm, &
                                .FALSE.)

      IF( this % gpuAccel )THEN
        CALL this % H % UpdateDevice()
      ENDIF

  END SUBROUTINE SetTopographyFromEqn_ShallowWater

  SUBROUTINE SetBoundaryCondition_ShallowWater(this)
    IMPLICIT NONE
    CLASS(ShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: iEl, iSide, i
    INTEGER :: bcid, e2
    REAL(prec) :: u, v, nhat(1:2)

!    IF( this % gpuAccel )THEN
!
!      CALL SetBoundaryCondition_ShallowWater_gpu_wrapper( this % solution % boundary % deviceData,&
!            this % solution % extBoundary % deviceData, &
!            this % geometry % nHat % boundary % deviceData, &
!            this % mesh % sideInfo % deviceData, &
!            this % solution % interp % N, &
!            this % solution % nVar, &
!            this % solution % nElem)
!
!    ELSE

      DO iEl = 1, this % solution % nElem
        DO iSide = 1, 4
            DO i = 0, this % solution % interp % N

              bcid = this % mesh % sideInfo % hostData(5,iSide,iEl) ! Boundary Condition ID
              e2 = this % mesh % sideInfo % hostData(3,iSide,iEl) ! Neighboring Element ID
              IF( e2 == 0 )THEN
                IF( bcid == SELF_BC_RADIATION )THEN

                  this % solution % extBoundary % hostData(i,1,iSide,iEl) = 0.0_prec
                  this % solution % extBoundary % hostData(i,2,iSide,iEl) = 0.0_prec
                  this % solution % extBoundary % hostData(i,3,iSide,iEl) = this % H % boundary % hostData(i,1,iSide,iEl)
                  !PRINT*, "Radiation Boundary, H :",this % solution % extBoundary % hostData(i,3,iSide,iEl)

                ELSEIF( bcid == SELF_BC_NONORMALFLOW )THEN

                  nhat(1:2) = this % geometry % nHat % boundary % hostData(1:2,i,1,iSide,iEl)
                  u = this % solution % boundary % hostData(i,1,iSide,iEl)
                  v = this % solution % boundary % hostData(i,2,iSide,iEl)
                  this % solution % extBoundary % hostData(i,1,iSide,iEl) = (nhat(2)**2 - nhat(1)**2)*u - 2.0_prec*nhat(1)*nhat(2)*v
                  this % solution % extBoundary % hostData(i,2,iSide,iEl) = (nhat(1)**2 - nhat(2)**2)*v - 2.0_prec*nhat(1)*nhat(2)*u
                  this % solution % extBoundary % hostData(i,3,iSide,iEl) = this % solution % boundary % hostData(i,3,iSide,iEl)

                ELSE ! Default boundary condition is radiation

                  this % solution % extBoundary % hostData(i,1,iSide,iEl) = 0.0_prec
                  this % solution % extBoundary % hostData(i,2,iSide,iEl) = 0.0_prec
                  this % solution % extBoundary % hostData(i,3,iSide,iEl) = this % H % boundary % hostData(i,1,iSide,iEl)

                ENDIF
              ENDIF

            ENDDO
        ENDDO
      ENDDO

!    ENDIF

  END SUBROUTINE SetBoundaryCondition_ShallowWater

  SUBROUTINE Source_ShallowWater(this)
    IMPLICIT NONE
    CLASS(ShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,j,iEl,iVar

!    IF( this % gpuAccel )THEN
!
!      CALL Source_ShallowWater_gpu_wrapper(this % source % interior % deviceData,&
!             this % solution % interior % deviceData, &
!             this % fCori,&
!             this % source % interp % N, &
!             this % solution % nVar, &
!             this % solution % nElem )
!
!    ELSE

      DO iEl = 1, this % source % nElem
        DO j = 0, this % source % interp % N
          DO i = 0, this % source % interp % N

            this % source % interior % hostData(i,j,1,iEl) = &
                    -this % fCori*this % solution % interior % hostData(i,j,2,iEl) +&
                    this % g*this % solution % interior % hostData(i,j,3,iEl)*&
                    this % gradH % interior % hostData(1,i,j,1,iEl)

            this % source % interior % hostData(i,j,2,iEl) = &
                    this % fCori*this % solution % interior % hostData(i,j,1,iEl) +&
                    this % g*this % solution % interior % hostData(i,j,3,iEl)*&
                    this % gradH % interior % hostData(2,i,j,1,iEl)

            this % source % interior % hostData(i,j,3,iEl) = 0.0_prec

          ENDDO
        ENDDO
      ENDDO

!    ENDIF

  END SUBROUTINE Source_ShallowWater

  SUBROUTINE Flux_ShallowWater(this)
    IMPLICIT NONE
    CLASS(ShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,j,iEl,iVar

!    IF( this % gpuAccel )THEN
!
!      CALL Flux_ShallowWater_gpu_wrapper(this % flux % interior % deviceData,&
!                                               this % solution % interior % deviceData, &
!                                               this % g, this % H, this % solution % interp % N, &
!                                               this % solution % nVar, this % solution % nElem)
!
!    ELSE
      DO iEl = 1, this % solution % nElem
        DO iVar = 1, this % solution % nVar
          DO j = 0, this % solution % interp % N
            DO i = 0, this % solution % interp % N

              IF ( iVar == 1 )THEN ! Hu

                ! Hu^2 + (gH^2)/2
                this % flux % interior % hostData(1,i,j,iVar,iEl) = &
                      this % velocity % interior % hostData(1,i,j,1,iEl)*& ! u
                      this % solution % interior % hostData(i,j,1,iEl)+& ! Hu
                      0.5_prec*this % g*this % solution % interior % hostData(i,j,3,iEl)*&
                      this % solution % interior % hostData(i,j,3,iEl)

                ! Huv
                this % flux % interior % hostData(2,i,j,iVar,iEl) = &
                      this % velocity % interior % hostData(2,i,j,1,iEl)*& ! v
                      this % solution % interior % hostData(i,j,1,iEl) ! Hu

              ELSEIF ( iVar == 2 )THEN !Hv

                ! Huv
                this % flux % interior % hostData(1,i,j,iVar,iEl) = &
                      this % velocity % interior % hostData(1,i,j,1,iEl)*& ! u
                      this % solution % interior % hostData(i,j,2,iEl) ! Hv

                ! (Hv^2 + (gH^2)/2)
                this % flux % interior % hostData(2,i,j,iVar,iEl) = &
                      this % velocity % interior % hostData(2,i,j,1,iEl)*& ! v
                      this % solution % interior % hostData(i,j,2,iEl)+& ! Hv
                      0.5_prec*this % g*this % solution % interior % hostData(i,j,3,iEl)*&
                      this % solution % interior % hostData(i,j,3,iEl)

              ELSEIF ( iVar == 3 )THEN ! H - total fluid thickness
                this % flux % interior % hostData(1,i,j,iVar,iEl) = &
                      this % solution % interior % hostData(i,j,1,iEl)

                this % flux % interior % hostData(2,i,j,iVar,iEl) = &
                      this % solution % interior % hostData(i,j,2,iEl)
              ENDIF

            ENDDO
          ENDDO
        ENDDO
      ENDDO
!    ENDIF

  END SUBROUTINE Flux_ShallowWater

  SUBROUTINE RiemannSolver_ShallowWater(this)
    IMPLICIT NONE
    CLASS(ShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,iSide,iEl
    REAL(prec) :: nhat(1:2), nmag
    REAL(prec) :: cL, cR, unL, unR, HL, HR, HuL, HuR, HvL, HvR
    REAL(prec) :: alpha
    REAL(prec) :: fluxL(1:3)
    REAL(prec) :: fluxR(1:3)

!    IF( this % gpuAccel )THEN
!
!      CALL RiemannSolver_ShallowWater_gpu_wrapper(this % flux % boundaryNormal % deviceData, &
!             this % solution % boundary % deviceData, &
!             this % solution % extBoundary % deviceData, &
!             this % geometry % nHat % boundary % deviceData, &
!             this % geometry % nScale % boundary % deviceData, &
!             this % g, this % H, &
!             this % solution % interp % N, &
!             this % solution % nVar, &
!             this % solution % nElem)
!
!    ELSE

      DO iEl = 1, this % solution % nElem
        DO iSide = 1, 4
          DO i = 0, this % solution % interp % N

             ! Get the boundary normals on cell edges from the mesh geometry
             nhat(1:2) = this % geometry % nHat % boundary % hostData(1:2,i,1,iSide,iEl)
             nmag = this % geometry % nScale % boundary % hostData(i,1,iSide,iEl)

             ! Calculate the normal velocity at the cell edges
             unL = this % velocity % boundary % hostData(1,i,1,iSide,iEl)*nHat(1)+&
                   this % velocity % boundary % hostData(2,i,1,iSide,iEl)*nHat(2)

             unR = this % velocity % extBoundary % hostData(1,i,1,iSide,iEl)*nHat(1)+&
                   this % velocity % extBoundary % hostData(2,i,1,iSide,iEl)*nHat(2)

             cL = sqrt( this % g * this % solution % boundary % hostData(i,3,iSide,iEl))
             cR = sqrt( this % g * this % solution % extBoundary % hostData(i,3,iSide,iEl))

             HuL = this % solution % boundary % hostData(i,1,iSide,iEl)
             HuR = this % solution % extBoundary % hostData(i,1,iSide,iEl)

             HvL = this % solution % boundary % hostData(i,2,iSide,iEl)
             HvR = this % solution % extBoundary % hostData(i,2,iSide,iEl)

             HL = this % solution % boundary % hostData(i,3,iSide,iEl)
             HR = this % solution % extBoundary % hostData(i,3,iSide,iEl)

             fluxL(1) = HuL*unL + this % g*HL*HL*0.5_prec*nHat(1)
             fluxL(2) = HvL*unL + this % g*HL*HL*0.5_prec*nHat(2)
             fluxL(3) = HuL*nHat(1) + HvL*nHat(2)

             fluxR(1) = HuR*unR + this % g*HR*HR*0.5_prec*nHat(1)
             fluxR(2) = HvR*unR + this % g*HR*HR*0.5_prec*nHat(2)
             fluxR(3) = HuR*nHat(1) + HvR*nHat(2)

             alpha = MAX( ABS(unL+cL), ABS(unR+cR), &
                          ABS(unL-cL), ABS(unR-cR) )

             ! Pull external and internal state for the Riemann Solver (Lax-Friedrichs)
             this % flux % boundaryNormal % hostData(i,1,iSide,iEl) = 0.5_prec*( &
                     fluxL(1) + fluxR(1) + alpha*( HuL - HuR ) )*nmag
             this % flux % boundaryNormal % hostData(i,2,iSide,iEl) = 0.5_prec*( &
                     fluxL(2) + fluxR(2) + alpha*( HvL - HvR ) )*nmag
             this % flux % boundaryNormal % hostData(i,3,iSide,iEl) = 0.5_prec*( &
                     fluxL(3) + fluxR(3) + alpha*( HL - HR ) )*nmag

          ENDDO
        ENDDO
      ENDDO

!    ENDIF

  END SUBROUTINE RiemannSolver_ShallowWater

END MODULE SELF_ShallowWater


module parameters
    use cudafor
    implicit none

    ! constant values
    real, parameter :: pi = acos(-1.0)
    real, parameter :: diam = 1.0

    ! User dependant parameters, host
    integer, parameter :: np = 18**3 ! number of particles
    real, parameter :: deltat = 0.00001 ! time step
    real, parameter :: sqtwodt = sqrt(2.0 * deltat)
    real, parameter :: ktemp = 1.4737 ! reduced temperature
    ! These variables can be read from a file
    real, managed :: boxl, rc
    real, managed :: phi, rho

    ! CUDA parameters
    integer, parameter :: blksz = 64
end module parameters


*     SB02MD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDG, LDQ, LDS, LDU
      PARAMETER        ( LDA = NMAX, LDG = NMAX, LDQ = NMAX,
     $                   LDS = 2*NMAX, LDU = 2*NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = 2*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 6*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION RCOND
      INTEGER          I, INFO, J, N
      CHARACTER        DICO, HINV, SCAL, SORT, UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX),
     $                 Q(LDQ,NMAX), S(LDS,2*NMAX), U(LDU,2*NMAX),
     $                 WI(2*NMAX), WR(2*NMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB02MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, DICO, HINV, UPLO, SCAL, SORT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
*        Find the solution matrix X.
         CALL SB02MD( DICO, HINV, UPLO, SCAL, SORT, N, A, LDA, G, LDG,
     $                Q, LDQ, RCOND, WR, WI, S, LDS, U, LDU, IWORK,
     $                DWORK, LDWORK, BWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) RCOND
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( Q(I,J), J = 1,N )
   20       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02MD = ',I2)
99997 FORMAT (' RCOND = ',F4.2,//' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END


!-------------!
 module system
!-------------!

 integer :: nn
 integer :: nst

 integer, allocatable :: state(:)

 real(8), allocatable :: mat(:,:)
 real(8), allocatable :: vec(:,:)
 real(8), allocatable :: enr(:)
 real(8), allocatable :: spn(:)

 end module system
!-----------------!

!================!
 program hchain_m
!================!
 use system; implicit none

 integer :: nu,mst

 open(10,file='read.in',status='old')
 read(10,*)nn
 close(10)

 mst=1
 do nu=(nn+1)/2+1,nn
    mst=mst*nu
 enddo
 do nu=2,nn/2
    mst=mst/nu
 enddo

 allocate(state(mst))

 open(10,file='eig.dat',status='replace')
 close(10)

 do nu=mod(nn,2),nn/2

    call makebasis(nu)

    allocate(mat(nst,nst))
    allocate(vec(nst,nst))
    allocate(enr(nst))
    allocate(spn(nst))

    call hamiltonian()
    call diagonalize(nst,mat,vec,enr)

    call spinsquared(nu)
    call transform(nst,mat,vec,spn)
    spn(:)=0.5d0*abs(sqrt(1.d0+4.d0*spn(:))-1.d0)

    call writedata(nu)

    deallocate(mat)
    deallocate(vec)
    deallocate(enr)
    deallocate(spn)

 enddo

 deallocate(state)

 end program hchain_m
!====================!

!------------------------!
 subroutine writedata(nu)
!------------------------!
 use system; implicit none

 integer :: i,nu

 open(10,file='eig.dat',position='append')
 write(10,*)'nu =',nu,'   nst =',nst
 do i=1,nst
    write(10,'(i5,2f18.10)')i-1,enr(i),spn(i)
 enddo
 close(10)

 end subroutine writedata
!------------------------!

!------------------------!
 subroutine makebasis(nu)
!------------------------!
 use system; implicit none

 integer :: i,s,n1,nu

 nst=0
 do s=0,2**nn-1
    n1=0
    do i=0,nn-1
       if (btest(s,i)) n1=n1+1
    enddo
    if (n1==nu) then
       nst=nst+1
       state(nst)=s
    endif
 enddo

 end subroutine makebasis
!------------------------!

!------------------------!
 subroutine hamiltonian()
!------------------------!
 use system; implicit none

 integer :: i,j,a,b,sa,sb

 mat(:,:)=0.d0
 do a=1,nst
    sa=state(a)
    do i=0,nn-1
       j=mod(i+1,nn)
       if (btest(sa,i).eqv.btest(sa,j)) then
          mat(a,a)=mat(a,a)+0.25d0
       else
          mat(a,a)=mat(a,a)-0.25d0
          sb=ieor(sa,2**i+2**j)
          call findstate(sb,b)
          mat(a,b)=0.5d0
       endif
    enddo
 enddo

 end subroutine hamiltonian
!--------------------------!

!--------------------------!
 subroutine spinsquared(nu)
!--------------------------!
 use system; implicit none

 integer :: i,j,a,b,sa,sb,nu

 mat(:,:)=0.d0
 do a=1,nst
    sa=state(a)
    mat(a,a)=(dfloat(nu)-dfloat(nn)/2.d0)**2+dfloat(nn)/2.d0
    do i=0,nn-1
    do j=i+1,nn-1
       if (btest(sa,i).neqv.btest(sa,j)) then
          sb=ieor(sa,2**i+2**j)
          call findstate(sb,b)
          mat(a,b)=1.d0
       endif
    enddo
    enddo
 enddo

 end subroutine spinsquared
!--------------------------!

!--------------------------!
 subroutine findstate(sa,a)
!--------------------------!
 use system; implicit none

 integer :: a,sa,amin,amax

 amin=1; amax=nst
 do
    a=amin+(amax-amin)/2
    if (sa<state(a)) then
       amax=a-1
    elseif (sa>state(a)) then
       amin=a+1
    else
       return
    endif
 enddo

 end subroutine findstate
!-------------------------!

!-------------------------------------!
 subroutine diagonalize(n,mat,vec,eig)
!-------------------------------------!
 implicit none

 integer :: n,info
 real(8) :: mat(n,n),vec(n,n),eig(n),work(n*(3+n/2))

 vec=mat
 call dsyev('V','U',n,vec,n,eig,work,n*(3+n/2),info)

 end subroutine diagonalize
!--------------------------!

!-----------------------------------!
 subroutine transform(n,mat,vec,dia)
!-----------------------------------!
 implicit none

 integer :: i,n
 real(8) :: mat(n,n),vec(n,n),dia(n)

 mat=matmul(mat,vec)
 mat=matmul(transpose(vec),mat)
 do i=1,n
    dia(i)=mat(i,i)
 enddo

 end subroutine transform
!------------------------!


      double precision function pythag(a,b)
      double precision a,b
c
c     finds dsqrt(a**2+b**2) without overflow or destructive underflow
c
      double precision p,r,s,t,u
      p = dmax1(dabs(a),dabs(b))
      if (p .eq. 0.0d0) go to 20
      r = (dmin1(dabs(a),dabs(b))/p)**2
   10 continue
         t = 4.0d0 + r
         if (t .eq. 4.0d0) go to 20
         s = r/t
         u = 1.0d0 + 2.0d0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 pythag = p
      return
      end


    SUBROUTINE kep_lanczos(n,imax,its,ijob,v,bv,alpha,beta,theta)
    IMPLICIT NONE
    INTEGER :: n,imax,its,ijob
    DOUBLE PRECISION :: v,bv,alpha,beta,theta
!
    DIMENSION :: alpha(imax),theta(imax)
    DIMENSION :: beta(0:imax)
    DIMENSION :: v(n,imax+1)
    DIMENSION :: bv(n,0:imax+1)
!
!   Local arguments
    INTEGER :: i,j,k,info,seed
    DOUBLE PRECISION :: dtmp,sub,y,work
!
    DIMENSION :: sub(IMAX-1)
    DIMENSION :: work(2*IMAX-2)
!
!-----------------------------------------------------------------------
!   Initialize
    IF(its.EQ.1) THEN
        IF(ijob.EQ.1) THEN
            bv(:,0) = 0.0D0
!           v(1):=random vector
            seed=1
            CALL kep_randnum(seed,n,v(:,1))
            v(:,1)=v(:,1)*2.0D0-1.0D0
!           Return to the caller for matvec bv(1):=B*v(1) >>>>>>>>>>>>>>
            ijob=2
            RETURN
        END IF
!>>>>>>>Return from the caller after matvec bv(1):=B*v(1)
        IF(ijob.EQ.2) THEN
!          beta(0):=|| v(1) ||_B
            CALL kep_innpro(n,v(:,1),bv(:,1),dtmp)
            IF(dtmp.LE.0.0D0) THEN
                WRITE(6,*) &
                & 'Subroutine kep_lanczos: Error in B-inner product'
                WRITE(6,*) 'beta(0) =', dtmp
                STOP
            END IF
            beta(0)=DSQRT(dtmp)
            ijob=10
        END IF
    END IF
!
!-----------------------------------------------------------------------
!   Main loop
    DO j=its,its
        IF(ijob.EQ.10) THEN
!           Normalize
            v(:,j)=v(:,j)/beta(j-1)
            bv(:,j)=bv(:,j)/beta(j-1)
!           Return to the caller for matvec bv(j+1):=A*v(j) >>>>>>>>>>>>
            ijob=20
            RETURN
        END IF
!>>>>>>>Return from the caller after matvec bv(j+1):=A*v(j)
        IF(ijob.EQ.20) THEN
!           Orthgonalize (Modified Gram-Schmidt)
!           bv(j+1):=bv(j+1)-B*v(j-1)*beta(j-1)
            bv(:,j+1)=bv(:,j+1)-bv(:,j-1)*beta(j-1)
!           alpha(j):=(v(j),bv(j+1))
            CALL kep_innpro(n,v(:,j),bv(:,j+1),dtmp)
            alpha(j)=dtmp
!           bv(j+1):=bv(j+1)-B*v(j)*alpha(j)
            bv(:,j+1)=bv(:,j+1)-bv(:,j)*alpha(j)
!           Return to the caller to solve linear equation >>>>>>>>>>>>>>
!               v(j+1):=B^(-1)*bv(j+1), B*v(j+1)=bv(j+1) for v(j+1)
            ijob=30
            RETURN
        END IF
!>>>>>>>Return from the caller after solving linear equation
        IF(ijob.EQ.30) THEN
!           beta(j):=|| v(j+1) ||_B
            CALL kep_innpro(n,v(:,j+1),bv(:,j+1),dtmp)
            IF(dtmp.LE.0.0D0) THEN
                WRITE(6,*) 'Subroutine kep_lanczos: Error in B-inner product'
                WRITE(6,*) 'j =', j, ',  beta(j) =', dtmp
                STOP
            END IF
            beta(j)=DSQRT(dtmp)
!           Eigenpair of tridiagonal matrix by LAPACK
            theta(1:j) = alpha(1:j)
            sub(1:j-1) = beta(1:j-1)
            CALL dstev('N',j,theta,sub,y,1,work,info)
            IF(info.NE.0) THEN
                WRITE(6,*) 'Subroutine kep_lanczos: Error in LAPACK dstev routine'
                WRITE(6,*) 'j =', j, ',  info =', info
                STOP
            END IF
            ijob=10
        END IF
    END DO
!
!-----------------------------------------------------------------------
    its=its+1
    RETURN
    END SUBROUTINE kep_lanczos


      module cdat

      integer*4 :: ipot

      real*8,public,parameter :: PI=4.d0*atan(1.0)

      integer,parameter :: nmax = 16

      complex*16,public,parameter::im=(0d0,1d0)

      real*8 :: al,beta

      integer*4 ::  Ntraj,kmax,kout,idum1,order,nbx,nby
      real*8 :: dt,amx,amy,ax0,ay0,ax,ay,qx0,qy0,px0,py0
      real*8 :: xmin,xmax,ymin,ymax
      save
      end module cdat

      program main
!----------------------------------------------------------------
!     trajectory guided gaussian basis
!----------------------------------------------------------------------
      use cdat

      implicit real*8(a-h,o-z)

      real*8,allocatable :: ke(:),v(:),x(:),y(:),u(:),px(:),py(:),w(:)
      real*8,allocatable :: du(:),qp(:),dv(:),ddv(:),s(:)

      complex*16,dimension(:,:),allocatable :: h,mat
      complex*16, allocatable :: c(:),c0(:),dc(:),c1(:)

!      complex*16, dimension(nmax,nmax) :: mat

!      complex*16, dimension(nmax) :: c,c0,dc

     	real*8 :: f(3),ki,ncm

      real*8 :: gasdev

      complex*16 :: z0,z1,z2,zn,z,cor0,cor1,cor2,cor

!      common/wave/q0,p0,a0,sigma
!      common/grid/xmin,xmax,dx,np

      open(100,file='energy.dat')
      open(101,file='phase.dat')
      open(102,file='aver.dat')
      open(103,file='wft.dat')
      open(104,file='wf0.dat')
      open(106,file='q.dat')
      open(105,file='p.dat')
      open(107,file='c.dat')
      open(108,file='xy0.dat')
      open(109,file='xyt.dat')
      open(110,file='cf0.dat')
      open(111,file='norm.dat')
      open(112,file='force')
      open(113,file='xc')
      open(115,file='cor.dat', status='unknown',action='write')
      open(117,file='cor2.dat')
      open(118,file='cor_asym.dat', status='unknown',action='write')
      open(119,file='cor_sym.dat', status='unknown',action='write')

      open(116,file='qforce.dat', status='unknown',action='write')

      call init_pars()

      ep = 1d-2
      Nb = nbx*nby
      ntraj = nb
      af = 0.1

      write(*,1002) ntraj
1002  format(/'1D QTM code with Gassian Basis '//,  &
              'analytic expression for matrix elements'//, &
              'system: Morse',//        &
              'number of basis:', i4//)

      allocate(y(ntraj),py(ntraj),x(nb),px(nb))

      allocate(ke(Ntraj),v(Ntraj),s(Ntraj), &
               w(Ntraj),du(Ntraj),u(Ntraj),dv(Ntraj),ddv(Ntraj))

      allocate(mat(Ntraj,Ntraj))
      allocate(c(Ntraj),c0(Ntraj),h(Ntraj,Ntraj),dc(Ntraj),c1(ntraj))

      pow = 4d0

!     grid size over whole range
      npx = 400
      npy = 400
      xmin = -6d0
      xmax = 6d0
      dx = (xmax-xmin)/dble(npx-1)
      ymin = -6d0
      ymax = 6d0
      dy = (ymax-ymin)/(npy-1)

! --- grid to sample initial points
      g = 0.8d0
      xl = qx0-g*dsqrt(pow/ax0)
      xr = qx0+g*dsqrt(pow/ax0)
      yl = qy0-g*dsqrt(pow/ay0)
      yr = qy0+g*dsqrt(pow/ay0)

      gx = (xr-xl)/dble(nbx-1)
      gy = (yr-yl)/dble(nby-1)

      px = px0
      py = py0

      do i=1,nbx
        do j=1,nby
          k = nby*(i-1)+j
!          x(i) = gasdev(idum1)
!          x(i) = x(i)/dsqrt(2d0*a0)+q0
          x(k) = xl+(i-1)*gx
          y(k) = yl+(j-1)*gy
!          w(k) = exp(-2d0*a0*(x(i)-q0)**2)*dsqrt(2d0*a0/pi)*gx
      enddo
      enddo

! --- action function

      s = 0d0

      do i=1,nb
        write(108,1000) x(i),y(i)
      enddo

! --- define gaussian width as half of bin size
!      al = 1d0/2d0/sigma**2
      sigx = sqrt(1d0/2d0/ax)
      sigy = sqrt(1d0/2d0/ay)

!      xint = 1.8d0*sigma

!     test distribution
!      an = 0d0
!      a1 = 0d0
!      do i=1,Ntraj
!        an = an+w(i)
!        a1 = a1+w(i)*x(i)
!      enddo
!      write(*,*) an,a1
!      write(*,*) xl,xr,gx

!     print out the initial conditions
      write(*,1001) sigx,sigy,ax0,ay0,Ntraj,kmax,dt,kout, &
      amx,amy,px0,py0,qx0,qy0,gx,gy

1001  format('Initial Conditions'//, &
            'width = ', 2f10.6/, &
            'a0    = ', 2f10.6/, &
            'Ntraj = ', i6/ ,   &
            'Kmax  = ', i6/ ,   &
            'dt    = ', f10.6/, &
            'kout  = ', i6/ ,   &
            'Mass  = ', 2f10.6/ ,&
            'p0    = ', 2f10.6/ ,&
            'q0    = ', 2f10.6/, &
            'dx,dy = ', 2f10.6)

!--------initial coeff---------------------
      write(*,1011)
1011  format(/'Computing inital coefficients'/)

      call proj(nb,x,y,px,py,s,c0)

      c = c0
      do i=1,nb
        write(110,1000) x(i),y(i),abs(c(i)),c(i)
      enddo

      print *,'position = ',(x(i),i=1,6)
      print *,'init c =',(c(i),i=1,6)
!------check normalization--------------
      z1 = (0d0,0d0)

      do i=1,npx
        xi = xmin+dx*(i-1)
        do j=1,npy
          yi = ymin+dy*(j-1)
          call psi(xi,yi,nb,c,x,y,s,z0)
          z1 = z1+conjg(z0)*z0*dx*dy
!        if(abs(z0).gt.1d-3) write(104,1000) xi,abs(z0)**2
        write(104,*) xi,yi,abs(z0)**2
        enddo
        write(104,*) ' '
      enddo

      write(*,1013)  real(z1)
1013  format('initial Normalization =', f16.8)

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

!     print out basis functions
!      do i=1,Np
!        xi = xmin+dx*dble(i-1)
!        z0 = dsqrt(dsqrt(al/pi))*exp(-al/2d0*(xi-x(1))**2+  &
!             im*p(1)*(xi-x(1)))
!        zn = dsqrt(dsqrt(al/pi))*exp(-al/2d0*(xi-x(2))**2+ &
!             im*p(nb)*(xi-x(2)))
!
!       if(abs(z0)>1d-3 .or. abs(zn)>1d-3) write(108,1000) xi,abs(z0)**2,abs(zn)**2
!
!!        if(abs(z0).gt.1d-3) write(108,1000) xi,abs(z0)**2
!!        if(abs(zn).gt.1d-3) write(109,1000) xi,abs(zn)**2
!      enddo
!
! --- initial force field

!      call derivs(x,Ntraj,v,dv,ddv)
!      call qpot(order,nb,ddv,c,am,p,x,s,w,u,du)

!      do i=1,nb
!        write(112,1000) x(i),v(i),dv(i),ddv(i),du(i)
!      enddo

!      call ham(am,w,c,nb,x,p,s,u,du,v,ddv,h)
!     call increm(nb,mat,h,c,dc)

!-----output at t=0-------------------
      t = 0.0
      write(107,1000) t,(abs(c(i)),i=1,Ntraj)
      dt = dt/kout
      dt2 = dt/2d0
      af = 0.0 !friction constant

      call ham0(c,nb,x,y,px,py,s,dc)

!      c1 = c
      c = c + dc*dt2
!      x = x + p*dt/am

!-----begin the time step loop----------
      time: do kt = 1,kmax

!        print *,'time step', kt

        do 13 kk=1,kout

          t = t+dt

!          call norm(nb,x,p,c,mat,an)

          c = c + dc*dt2

!          call norm(nb,x,y,px,py,c,s,an)
!          c = c/dsqrt(an)

          call mom(nb,x,y,px,py,c,s)

          x = x + px*dt/amx
          y = y + py*dt/amy

!-------------update dc/dt--------------------
!          call derivs(nb,x,v,dv,ddv)

        call ham0(c,nb,x,y,px,py,s,dc)

        c = c + dc*dt2

! --------- friction
          call norm(nb,x,y,px,py,c,s,anm)
          c = c/dsqrt(anm)

13      enddo
!        call norm(nb,x,y,px,py,c,s,an)
        write(111,1000) t,an

        call aver(nb,x,y,px,py,s,c,xav,yav)
        write(102,1000) t,xav,yav

!        if(k == kmax) then
!        do i=1,nb
!          write(116,1000) x(i),du(i)
!        enddo
!        endif

! ----- correlation function

!        call permute(nb,x,y,px,py,c,s,cor0,cor1,cor2)
!        write(115,1000) t,cor0,cor1,cor2

        call corr(nb,x,y,px,py,c,s,cor)
        write(117,1000) t*2d0,cor

        write(107,1000) t,(abs(c(i)),i=1,nb)

!       print out trajectories in phase space
!        write(101,1000) (x(i),i=1,nb),(p(i),i=1,nb)

        write(105,1000) t,(px(i),i=1,Nb,nby)
        write(106,1000) t,(x(i),i=1,Nb)
!       calculate the total energy
        enk = 0d0
        env = 0d0
        enq = 0d0

!        do i=1,Nb
!          env = env+v(i)*w(i)
!          enk = enk+p(i)**2/2d0/am*w(i)
!          enq = enq+u(i)*w(i)
!        enddo

!        en = enk+env+enq

!        write(100,1000) t,enk,env,enq,en
!        call flush(100)

!-------------average position --------------
!        call aver(Ntraj,x,p,c,xav)
!        write(102,1000) t,xav

      end do time

!--------print x,c--------------
        do i=1,nb
          write(113,1000) x(i),abs(c(i))
        enddo

      do i=1,nb
        write(109,1000) x(i),y(i),px(i),py(i)
      enddo
!---------check matrix singularity--------------
!        do i=1,nb
!          write(*,1018) (mat(i,j),j=1,nb)
!        enddo
!        call eigen(nb,mat)

!1018    format(20(f6.4,1x))

!     print out final wavefunction
      prob = 0d0

      do i=1,npx
        xi = xmin + dx*(i-1)
        do j=1,npy
          yi = ymin + dy*(j-1)
          call psi(xi,yi,nb,c,x,y,s,z0) !    if(abs(z0).gt.1d-3)
          write(103,*) xi,yi,abs(z0)**2
          prob = prob+abs(z0)**2*dx*dy
        enddo
        write(103,*) ' '
      enddo

      write(*,*) 'Final prob = ',prob

      open(114,file='temp.dat')
      write(114,*) t
      write(114,*) kmax,',',dt,',',kout
      write(114,*) amx,amy
      write(114,*) idum1
      write(114,*) gx,gy
      write(114,*) nb
      write(114,*) ax,ay,beta

      write(114,*) (x(i),i=1,nb)
      write(114,*) (y(i),i=1,nb)
!      write(114,*) (p(i),i=1,nb)
!      write(114,*) (s(i),i=1,nb)
      write(114,*) (c(i),i=1,nb)
      close(114)

      close(111)
      close(112)
      close(113)
      close(115)

1000 format(2000(e16.7,1x))
      end program main

! ---- autocorrelation using symmetrized wavefunction --------

      subroutine permute(nb,x,y,px,py,c,s,cor0,cor1,cor2)

      use cdat, only: im,pi,ax,ay,px0,py0,qx0,qy0,ax0,ay0

      implicit real*8(a-h,o-z)
      real*8,dimension(nb) :: x,y,px,py,s
      complex*16,dimension(nb) :: c
      complex*16, dimension(nb) ::  z0,z2,z1,z3
      complex*16, dimension(nb,nb) :: mat
      complex*16 z,cor0,cor1,cor2

      a = ax
      alfx = 2d0*ax0
      alfy = 2d0*ay0
      asx = ax+alfx
      asy = ay+alfy

      avx=ax*alfx/asx
      avy=ax*alfy/asy

      an0=dsqrt(2d0*dsqrt(avx/asx))*dsqrt(2d0*dsqrt(avy/asy))

!      an0=dsqrt(dsqrt(a/pi))
!      an2=dsqrt(dsqrt(alfa/pi))

!---- compute c0_k = <psi0|g_k>
      do j=1,nb
        dx = qx0-x(j)
        dy = qy0-y(j)
        dpx = px0+im*ax*dx
        dpy = py0+im*ay*dy
!        z = -0.5d0*(dpx**2/asx+dpy**2/asy) - 0.5d0*(ax*dx*dx+ay*dy**2)
        d2 = -0.5d0*avx*dx**2-0.5d0*avy*dy**2
!        d0=-0.5d0/as*dp*dp
!        d1=(a*p0)/as*dq
!        c0(j)=exp(d2+d0+im*d1)*an
        z0(j) = an0*exp(d2)
      enddo

!---- compute c0_k = <permuted psi0|g_k>
      alfx = 2d0*ay0
      alfy = 2d0*ax0
      asx = ax+alfx
      asy = ay+alfy

      avx=ax*alfx/asx
      avy=ax*alfy/asy

      an1=dsqrt(2d0*dsqrt(avx/asx))*dsqrt(2d0*dsqrt(avy/asy))

      do j=1,nb
        dx = qy0-x(j)
        dy = qx0-y(j)
        dpx = py0+im*ax*dx
        dpy = px0+im*ay*dy
!        z = -0.5d0*(dpx**2/asx+dpy**2/asy) -0.5d0*(ax*dx*dx+ay*dy*dy)
      d2 = -0.5d0*avx*dx**2-0.5d0*avy*dy**2
        z1(j) = an1*exp(d2)
      enddo

      cor0 = (0d0,0d0)
      cor1 = (0d0,0d0)
      cor2 = (0d0,0d0)

      do j=1,nb
        cor0 = cor0 + z0(j)*exp(im*s(j))*c(j)
        cor1 = cor1 + (z0(j)+z1(j))*exp(im*s(j))*c(j)
        cor2 = cor2 + (z0(j)-z1(j))*exp(im*s(j))*c(j)
      enddo

      return
      end subroutine

! ---- update momentum

      subroutine mom(nb,x,y,px,py,c,s)

      use cdat, only : ax,ay,pi,beta

      implicit real*8(a-h,o-z)

      real*8,dimension(nb) ::  x,y,px,py,s
      complex*16 c(nb),z,z0,dz1,dz2

! ----- Gaussian convolution

      an0 = dsqrt(dsqrt(ax*ay/pi**2))
!      alfax = ax
!      alfay = ay

      an0 = an0*dsqrt(beta/(beta+ax))*dsqrt(beta/(beta+ay))
      alfax = beta*ax/(beta+ax)
      alfay = beta*ay/(beta+ay)

      do j=1,nb
        z = (0d0,0d0)
        dz1 = (0d0,0d0)
        dz2 = (0d0,0d0)
!        s1 = x(j)
!        s2 = y(j)
        do i=1,nb
          dx = x(j)-x(i)
          dy = y(j)-y(i)
          z0 = c(i)*exp(-0.5*(alfax*dx**2+alfay*dy**2))*an0
          z = z + z0
          dz1 = dz1 - alfax*dx*z0
          dz2 = dz2 - alfay*dy*z0
        enddo
        px(j) = imag(dz1/z)
        py(j) = imag(dz2/z)
      enddo

      return
      end subroutine
!------------------------------------------------

! --- autocorrelation
!      double complex function corr(nb,c0,c,x,y,px,py,s)
!
!      use cdat, only: im,pi,ax,ay,px0,py0,qx0,qy0,ax0,ay0
!
!      implicit real*8 (a-h,o-z)
!
!      real*8, intent(in),dimension(nb) :: x,y,px,py,s
!      complex*16, intent(in) :: c(nb),c0(nb)
!
!      complex*16 :: mat(nb,nb),z0,z(nb),dpx,dpy
!!      common/wave/q0,p0,a0,sigma
!
!      a = ax
!      alfx = 2d0*ax0
!      alfy = 2d0*ay0
!      asx = ax+alfx
!      asy = ay+alfy
!
!      avx=ax*alfx/asx
!      avy=ax*alfy/asy
!
!      an=dsqrt(2d0*dsqrt(avx/asx))*dsqrt(2d0*dsqrt(avy/asy))
!
!      an0=dsqrt(dsqrt(a/pi))
!      an2=dsqrt(dsqrt(alfa/pi))
!!---- compute c0_k = <psi0|g_k>
!      do j=1,nb
!        dx = qx0-x(j)
!        dy = qy0-y(j)
!        dpx = px0+im*ax*dx
!        dpy = py0+im*ay*dy
!        z(j) = -0.5d0*(dpx**2/asx+dpy**2/asy) -0.5d0*(ax*dx*dx+ay*dy**2)
!!        d0=-0.5d0/as*dp*dp
!!        d1=(a*p0)/as*dq
!!        c0(j)=exp(d2+d0+im*d1)*an
!        z(j) = an*exp(z(j))
!      enddo
!
!      corr = (0d0,0d0)
!      do j=1,nb
!          corr = corr + z(j)*exp(im*s(j))*c(j)
!      enddo
!
!      end function

! --- compute wavefunction value at point x

      subroutine psi(xi,yi,nb,c,x,y,s,z)

      use cdat, only : im,pi,ax,ay

      implicit real*8(a-h,o-z)
      real*8 ,intent(in) :: xi,yi
      integer*4 :: nb
      real*8, intent(in), dimension(nb) :: x,y,s
      complex*16,intent(in) :: c(nb)

      complex*16, intent(out) :: z

      anrm = dsqrt(dsqrt(ax*ay/pi/pi))

      z = (0d0, 0d0)
      do j=1,nb
        z = z + c(j)*exp(-ax/2d0*(xi-x(j))**2-ay/2d0*(yi-y(j))**2+im*s(j))*anrm
      enddo

      return
      end subroutine

! --- compute non-classical momemtum

!      double precision function ncm(x,nb,c,q,p,s)

!      use cdat, only : im,pi,al

!      implicit real*8(a-h,o-z)
!      real*8 ,intent(in) :: x
!      integer*4 :: nb
!      real*8, intent(in),dimension(nb) :: q,p,s
!      complex*16 :: c(nb),psi,dpsi,z0,z1,gi,gj

!      anrm = dsqrt(dsqrt(al/pi))

!      ncm = 0d0
!      do i=1,nb
!        ncm = ncm+abs(c(i))**2*anrm**2*exp(-al*(x-q(i))**2)
!      enddo

!      h = 1d-4
!      z0 = psi(x,nb,c,q,p,s)
!      xx = x+h
!      z1 = psi(xx,nb,c,q,p,s)
!      xx = x-h
!      z2 = psi(xx,nb,c,q,p,s)
!      ncm = (abs(z2)-abs(z1))/(2d0*h*abs(z0))

!      den = conjg(z0)*z0
!      den1 = conjg(z1)*z1
!      ncm = (den1-den0)/(2d0*h*den0)

!      do i=2,nb
!        do j=1,i-1
!          dq = q(i)-q(j)
!          dp = p(i)-p(j)
!          xs = (q(i)+q(j))/2d0
!          ps = (p(i)+p(j))/2d0
!          ncm = ncm+anrm**2*real(conjg(c(i))*c(j)*(-al*(2d0*x-q(i)-q(j))-im*dp) &
!                *exp(-al*(x-xs)-im*dp*(x-xs)+im*ps*dq+im*(s(j)-s(i))))
!        enddo
!      enddo
!      ncm = ncm/den
!      do i=1,nb
!        do j=1,nb
!          dp = p(i)-p(j)
!          gi = anrm*exp(-al/2d0*(x-q(i))**2+im*p(i)*(x-q(i))+im*s(i))
!          gj = anrm*exp(-al/2d0*(x-q(j))**2+im*p(j)*(x-q(j))+im*s(j))
!          ncm = ncm+conjg(c(i))*c(j)*(-al*(2d0*x-q(i)-q(j))-im*dp)*conjg(gi)*gj
!        enddo
!      enddo

!      ncm = ncm/(2d0*den)

! --- analytical way to compute r(x)
!      z0 = psi(x,nb,c,q,p,s)
!      z1 = dpsi(x,nb,c,q,p,s)

!      ncm = real(conjg(z0)*z1/abs(z0)**2)

!      end function

      subroutine dpsi(x,nb,c,q,s,z)

      use cdat, only : im,pi,al

      implicit real*8(a-h,o-z)

      real*8 ,intent(in) :: x
      integer*4 :: nb
      real*8, intent(in), dimension(nb) :: q,s
      complex*16,intent(in) :: c(nb)
      complex*16 :: gj

      complex*16, intent(out) :: z

      anrm = dsqrt(dsqrt(al/pi))

      z = (0d0, 0d0)
      do j=1,nb
        gj = exp(-al/2d0*(x-q(j))**2+im*s(j))*anrm
        z = z + c(j)*(-al*(x-q(j)))*gj
      enddo

      end subroutine

!------normalizati-----------------------------
      subroutine norm(nb,x,y,px,py,c,s,anrm)

      use cdat, only : pi, al, im

      implicit real*8(a-h,o-z)

      integer*4, intent(in) :: nb

      real*8, dimension(nb) :: x,y,px,py,s

      complex*16, intent(in) :: c(nb)

      complex*16 :: mat(nb,nb),z

      real*8, intent(out) :: anrm

      z = (0d0,0d0)

      call multi(nb,x,y,px,py,s,mat)

      do j=1,nb
        do k=1,nb
          z = z + conjg(c(j))*mat(j,k)*c(k)
        enddo
      enddo

      anrm = real(z)

      return
      end subroutine

      subroutine corr(nb,x,y,px,py,c,s,z)

      use cdat, only : pi, al, im

      implicit real*8(a-h,o-z)

      integer*4, intent(in) :: nb

      real*8, dimension(nb) :: x,y,px,py,s

      complex*16, intent(in) :: c(nb)

      complex*16 :: mat(nb,nb)

      complex*16, intent(out) :: z

      z = (0d0,0d0)

      call multi(nb,x,y,px,py,s,mat)

      do j=1,nb
        do k=1,nb
          z = z + c(j)*mat(j,k)*c(k)
        enddo
      enddo

      return
      end subroutine
!     ----------------------------------------------
!     average x
!     ---------------------------------------------
      subroutine aver(nb,x,y,px,py,s,c,xav,yav)
      use cdat

      implicit real*8(a-h,o-z)
      integer*4,intent(in) :: nb
      real*8,intent(in),dimension(nb):: x,y,px,py,s
      complex*16, intent(in) :: c(nb)
      real*8,intent(out) :: xav
      complex*16 :: psi,z
!      common/wave/q0,p0,a0,sigma
!      common/grid/xmin,xmax,dx,np

      z0 = (0d0,0d0)
      z1 = (0d0,0d0)
      do j=1,nb
        do k=1,nb
          dx = x(j)-x(k)
          dy = y(j)-y(k)
          xjk = 0.5d0*(x(j)+x(k))*exp(-ax*dx**2/4d0-ay*dy**2/4d0)
          yjk = 0.5d0*(y(j)+y(k))*exp(-ax*dx**2/4d0-ay*dy**2/4d0)
          z0 = z0 + conjg(c(j))*xjk*c(k)
          z1 = z1 + conjg(c(j))*yjk*c(k)
        enddo
      enddo

      xav = real(z0)
      yav = real(z1)

      return
      end subroutine
!     -----------------------------------
!     gassian wavepackets overlap matrix, analytic solution
!     -----------------------------------
      subroutine multi(nb,x,y,px,py,s,mat)

      use cdat, only : im,pi,ax,ay

      implicit real*8(a-h,o-z)
      integer*4, intent(in) :: nb
      real*8   , intent(in) :: x(nb),y(nb),px(nb),py(nb),s(nb)
      complex*16,intent(out) :: mat(nb,nb)
      complex*16 :: z,z0
!      common/wave/q0,p0,a0,sigma

      anrm = dsqrt(dsqrt(ax*ay/pi**2))
      do j=1,nb
        do k=1,j
          dqx = x(j)-x(k)
          dqy = y(j)-y(k)
          zx = dqx/2d0
          zy = dqy/2d0
          z0 = exp(-ax*zx**2-ay*zy**2)
          mat(j,k) = z0*exp(im*(s(k)-s(j)))
        enddo
      enddo

      do j=2,nb
        do k=1,j-1
          mat(k,j) = conjg(mat(j,k))
        enddo
      enddo

      return
      end subroutine
! --------------------------------------------
      subroutine pot(x,y,v0)
      implicit real*8(a-h,o-z)

!      ipot = 0

!      if (ipot == 0) then
        ep = 0.2d0

!        v0 = x**2/2d0 + y**2/2d0+ep*x**4/4
!        v11 = 1d0+3d0*ep*x**2
!        v22 = 1d0
      v0 = 0.5*(x**2+y**2)+1d0/abs(x+y)
!      v11 = -4d0/x**3+2d0/(x+y)**3
!      v22 = -4d0/y**3+2d0/(x+y)**3

!      elseif(ipot == 1) then
!        eta = 1.3544d0
!        v = 1d0/16d0/eta*x**4-0.5d0*x**2
!        dv(i) = 1d0/4d0/eta*x**3-x
!        ddv = 3d0/4d0/eta*x**2-1d0
!      endif

      return
      end subroutine

      subroutine ham0(c,nb,x,y,px,py,s,dc)

      use cdat

      implicit real*8(a-h,o-z)

      integer*4, intent(in) :: nb
      complex*16, dimension(nb), intent(in) :: c
      real*8, intent(in), dimension(nb) :: x,y,px,py,s

      complex*16,intent(out) :: dc(nb)

      complex*16, dimension(nb,nb) :: h,mat
      real*8 :: aux(nb,nb)

      complex*16 :: z,z0,d0,d1,d2,b(nb),d3
      real*8 b1(nb,2)

      call multi(nb,x,y,px,py,s,mat)

      anrm = dsqrt(dsqrt(ax*ay/pi**2))

      va = 1d0
      vb = 4d0
      vc = 1d0

      do j=1,nb
        do k=1,nb
          dx = x(k) - x(j)
          dy = y(k) - y(j)
!          z = dq/2d0
          z0 = exp((-ax*dx**2-ay*dy**2)/4d0)
          d0 = ax/(4d0*amx)*(1d0-ax/2d0*dx**2)+ay/(4d0*amy)*(1d0-ay/2d0*dy**2) ! kinetic
          xc = (x(j)+x(k))
          yc = (y(j)+y(k))
!          call pot(xc,yc,v0,v11,v22)

         d1 = vc*xc**2/8d0 + vc*yc**2/8d0 - vb*yc**2/4d0 + vb**2/4d0/va -vc* xc*yc/4d0 &
               + va*yc**4/16d0 + &
             (3d0/4d0)*va*yc**2/ay + vc/ax/4d0 + vc/4d0/ay -vb/2d0/ay+ 3d0*va/(4d0*ay**2)
!     -----------------------
!          d1 = 0.5d0*(xc**2 + 0.5/ax + yc**2 + 0.5/ay) ! potential
!          xt = abs(x(j)+x(k))/dsqrt(2d0*ax)
!          yt = abs(y(j)+y(k))/dsqrt(2d0*ay)
!          dxy = (x(j)+x(k))/dsqrt(2d0*ax) - (y(j)+y(k))/dsqrt(2d0*ay) ! need check when ax != ay
!          dxy = abs(dxy)
!          d1 = -2d0*(erf(dsqrt(ax)*xt)/xt + erf(dsqrt(ay)*yt)/yt) + erf(dsqrt(ax*ay/(ax+ay))*dxy)/dxy
!          d3 = erf(dsqrt(ax*ay/(ax+ay))*dxy)/dxy  ! Columb potential
!     --------------------
          d2 = im*px(k)*ax/(2d0*amx)*dx + im*py(k)*ay/(2d0*amy)*dy
          h(j,k) = z0*(d0+d1+d2)
        enddo
      enddo

      b = matmul(h,c)

      do i=1,nb
        b1(i,1) = real(b(i))
        b1(i,2) = imag(b(i))
      enddo

!      call inverse(mat,mativs,nb)

!-------save the overlap matrix-----------
      do i=1,nb
      do j=1,nb
        aux(i,j) = real(mat(i,j))
      enddo
      enddo

      call dposv('U', nb, 2, aux, nb, b1, nb, INFO)
      if(INFO .ne. 0) then
        write(*,*) 'dC/dt: Matrix fails, INFO =',INFO
        stop
      endif
!------compute increment dc------------
      do j=1,nb
        dc(j) = -im*(b1(j,1)+im*b1(j,2))
      enddo

      return
      end subroutine

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

      subroutine increm(nb,mat,h,c,dc)
      use cdat, only:im,pi
      implicit real*8(a-h,o-z)
      complex*16,intent(in) :: mat(nb,nb),h(nb,nb),c(nb)
      complex*16,intent(out) :: dc(nb)
      complex*16 b(nb),aux(nb,nb)
!---------H*c---------------
!      do i=1,Nb
!        b(i) = (0d0,0d0)
!        do j=1,Nb
!          b(i) = b(i)+h(i,j)*c(j)
!        enddo
!      enddo
      b = matmul(h,c)
!      b = -im*b

!-------save the overlap matrix-----------
      aux = mat
!      do i=1,Nb
!        write(*,1023) (aux(i,j),j=1,nb)
!      enddo
!      write(*,*) (b(i),i=1,Nb)
!1023  format(100(f6.4,1x))
      call zposv('U', Nb, 1, aux, nb, b, nb, INFO)
      if(INFO .ne. 0) then
        write(*,*) 'dC/dt: Matrix fails, INFO =',INFO
        stop
      endif
!------compute increment dc------------
      do j=1,nb
        dc(j) = -im*b(j)
      enddo
!      dc = b

      return
      end subroutine
!     ----------------------------------------------
!     initial coefficients before gaussian basis
!     ----------------------------------------------
      subroutine proj(nb,x,y,px,py,s,c)

      use cdat

      implicit real*8(a-h,o-z)
      integer*4,intent(in) :: nb
      real*8,intent(in),dimension(nb) :: x,y,px,py,s

      complex*16,intent(out) :: c(nb)

      complex*16 :: c0(nb)
      complex*16 :: z,z0,mat(nb,nb),psi0,aux(nb,nb)

!      common/wave/q0,p0,a0,sigma
!      a = ax
      alfx = 2d0*ax0
      alfy = 2d0*ay0
      asx = ax+alfx
      asy = ay+alfy
      avx = ax*alfx/asx
      avy = ay*alfy/asy
      an = dsqrt(2d0*dsqrt(avx/asx)*2d0*dsqrt(avy/asy))
      an0=dsqrt(dsqrt(ax/pi)*dsqrt(ay/pi))
      an2=dsqrt(dsqrt(alfx/pi)*dsqrt(alfy/pi))
!------compute c_k=<g_k|psi0>---------
      do j=1,nb
        dx = x(j)-qx0
        dy = y(j)-qy0
        dpx = px(j)- px0
        dpy = py(j)-py0

        d2=-0.5d0*avx*dx**2-0.5d0*avy*dy**2
        d0=-0.5d0/asx*dpx**2-0.5d0/asy*dpy**2
        d1=(alfx*px(j)+ax*px0)/asx*dx + (alfy*py(j)+ay*py0)/asy*dy
        c0(j)=exp(d2+d0+im*d1)*an
      enddo

!     intial wavepacket is also a gaussian (p0,q0) with the same width
!     as basis
!      do j=1,nb
!        dq = q(j)-q0
!        z = dq/2d0-im/2d0/al*(p(j)-p0)
!        z0 = exp(-al*z*conjg(z)+im/2d0*(p(j)+p0)*dq)
!        c0(j) = z0*dsqrt(dsqrt(al/pi))
!      enddo

!     a0 not equal to al

!      do j=1,nb
!        z = (0d0,0d0)
!        do i=1,Np
!          x = xmin+dx*(i-1)
!          z0 = exp(-al/2d0*(x-q(j))**2+im*p(j)*(x-q(j)))
!          psi0 = exp(-a0/2d0*(x-q0)**2+im*p0*(x-q0))
!          z = z+conjg(z0)*psi0*dx*dsqrt(dsqrt(a0*al)/pi)
!        enddo
!        c0(j) = z
!      enddo

!     solve matrix equation, Mc = b
!      do i=1,nb
!        write(*,1009) (mat(i,j),j=1,Nb)
!      enddo
!1009  format(20(f5.2,1x))
!------save overlap matrix------------------

      call multi(nb,x,y,px,py,s,mat)

      aux = mat

      call zposv('U', Nb, 1, aux, nb, c0, nb, INFO)

      IF( INFO.ne.0 ) THEN
         WRITE(*,1222) INFO
1222     format('INFO = ', i6/ ,'projection fails.'/)
         STOP
      END IF

      do i=1,nb
        c(i) = c0(i)
      enddo

      return
      end subroutine


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

!********************************************************************************
!* @file reflec_bounds_subroutine_1D.f90
!*
!* @Reflective Boundary Conditions Subroutine in 1D: Fortran 90 version.
!*
!* @author Andrew Hannington (ath4@st-andrews.ac.uk)
!********************************************************************************

!-------------------------------------------------------------------------------
!Compact subroutine for reflective boundary conditions. Reverses the direction of
!velocity and momentum
!-------------------------------------------------------------------------------
subroutine bounds

	use constants
	implicit none
		integer :: i,j,k,d
		Real*8 :: m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
			& grad_d_x,grad_d_y,grad_d_z, &
			& grad_ux_x,grad_uy_x,grad_uz_x, &
			& grad_ux_y,grad_uy_y,grad_uz_y, &
			& grad_ux_z,grad_uy_z,grad_uz_z, &
			& grad_p_x,grad_p_y,grad_p_z

!	Cells format: 	cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)

	d=1									!Counter to move over variables within a cell for two ghost cells
	i=1
	j=1
	k=1

!==============================================================================
!*****			X-Axis Face Ghost Cells:			  ******
!==============================================================================

!	Face normal to: -ve x-axis
	i=1
	j=1
	k=1
	Do while(k<=1)
		j=1
		Do while(j<=1)!NcY)

!	Set values of this face equal to those +2 cell in x-direction. Equal and opposite for x-vel. and x-mom.:
			m=cells(i+1,j,k,mn)
			qx=-1.d0*cells(i+1,j,k,qxn)
			qy=+1.d0*cells(i+1,j,k,qyn)
			qz=+1.d0*cells(i+1,j,k,qzn)
			E = cells(i+1,j,k,En)
			rho = cells(i+1,j,k,rhon)
			ux = -1.d0*cells(i+1,j,k,uxn)
			uy = +1.d0*cells(i+1,j,k,uyn)
			uz = +1.d0*cells(i+1,j,k,uzn)
			p = cells(i+1,j,k,pn)
			V = cells(i+1,j,k,Vn)

!	Set position of faces equal to those already assigned in Cell Setup:
			Midx=cells(i,j,k,xn)
			Midy=cells(i,j,k,yn)
			Midz=cells(i,j,k,zn)

!	Set gradients to zero for reflective boundary:
			grad_d_x= 0.d0
			grad_d_y=0.d0
			grad_d_z=0.d0
			grad_ux_x=0.d0
			grad_uy_x=0.d0
			grad_uz_x=0.d0
			grad_ux_y=0.d0
			grad_uy_y=0.d0
			grad_uz_y=0.d0
			grad_ux_z=0.d0
			grad_uy_z=0.d0
			grad_uz_z=0.d0
			grad_p_x=0.d0
			grad_p_y=0.d0
			grad_p_z=0.d0

			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
						& grad_d_x,grad_d_y,grad_d_z, &
						& grad_ux_x,grad_uy_x,grad_uz_x, &
						& grad_ux_y,grad_uy_y,grad_uz_y, &
						& grad_ux_z,grad_uy_z,grad_uz_z, &
						& grad_p_x,grad_p_y,grad_p_z /)
			j=j+1
		enddo
		k=k+1
	enddo

!	Face normal to: +ve x-axis
	i=NcX
	j=1
	k=1
	Do while(k<=1)
		j=1
		Do while(j<=1)!NcY)

!	Set values of this face equal to those NcX-1 cell in x-direction. Equal and opposite for x-vel. and x-mom.:
			m=cells(i-1,j,k,mn)
			qx=-1.d0*cells(i-1,j,k,qxn)
			qy=+1.d0*cells(i-1,j,k,qyn)
			qz=+1.d0*cells(i-1,j,k,qzn)
			E = cells(i-1,j,k,En)
			rho = cells(i-1,j,k,rhon)
			ux = -1.d0*cells(i-1,j,k,uxn)
			uy = +1.d0*cells(i-1,j,k,uyn)
			uz = +1.d0*cells(i-1,j,k,uzn)
			p = cells(i-1,j,k,pn)
			V = cells(i-1,j,k,Vn)

!	Set position of faces equal to those already assigned in Cell Setup:
			Midx=cells(i,j,k,xn)
			Midy=cells(i,j,k,yn)
			Midz=cells(i,j,k,zn)

!	Set gradients to zero for reflective boundary:
			grad_d_x= 0.d0
			grad_d_y=0.d0
			grad_d_z=0.d0
			grad_ux_x=0.d0
			grad_uy_x=0.d0
			grad_uz_x=0.d0
			grad_ux_y=0.d0
			grad_uy_y=0.d0
			grad_uz_y=0.d0
			grad_ux_z=0.d0
			grad_uy_z=0.d0
			grad_uz_z=0.d0
			grad_p_x=0.d0
			grad_p_y=0.d0
			grad_p_z=0.d0

			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
						& grad_d_x,grad_d_y,grad_d_z, &
						& grad_ux_x,grad_uy_x,grad_uz_x, &
						& grad_ux_y,grad_uy_y,grad_uz_y, &
						& grad_ux_z,grad_uy_z,grad_uz_z, &
						& grad_p_x,grad_p_y,grad_p_z /)
			j=j+1
		enddo
		k=k+1
	enddo

!==============================================================================
!*****			y-Axis Face Ghost Cells:			  ******
!==============================================================================
!
!!	Face normal to: -ve y-axis
!	i=1
!	j=1
!	k=1
!	Do while(k<=1)
!		i=1
!		Do while(i<=NcX)
!
!!	Set values of this face equal to those +2 cell in y-direction. Equal and opposite for x-vel. and x-mom.:
!			m=cells(i,j+1,k,mn)
!			qx=+1.d0*cells(i,j+1,k,qxn)
!			qy=-1.d0*cells(i,j+1,k,qyn)
!			qz=+1.d0*cells(i,j+1,k,qzn)
!			E = cells(i,j+1,k,En)
!			rho = cells(i,j+1,k,rhon)
!			ux = +1.d0*cells(i,j+1,k,uxn)
!			uy = -1.d0*cells(i,j+1,k,uyn)
!			uz = +1.d0*cells(i,j+1,k,uzn)
!			p = cells(i,j+1,k,pn)
!			V = cells(i,j+1,k,vn)
!
!!	Set position of faces equal to those already assigned in Cell Setup:
!			Midx=cells(i,j,k,xn)
!			Midy=cells(i,j,k,yn)
!			Midz=cells(i,j,k,zn)
!
!!	Set gradients to zero for reflective boundary:
!			grad_d_x= 0.d0
!			grad_d_y=0.d0
!			grad_d_z=0.d0
!			grad_ux_x=0.d0
!			grad_uy_x=0.d0
!			grad_uz_x=0.d0
!			grad_ux_y=0.d0
!			grad_uy_y=0.d0
!			grad_uz_y=0.d0
!			grad_ux_z=0.d0
!			grad_uy_z=0.d0
!			grad_uz_z=0.d0
!			grad_p_x=0.d0
!			grad_p_y=0.d0
!			grad_p_z=0.d0
!
!			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)
!			i=i+1
!		enddo
!		k=k+1
!	enddo
!
!!	Face normal to: +ve y-axis
!	i=1
!	j=NcY
!	k=1
!	Do while(i<=1)
!		i=1
!		Do while(i<=NcX)
!
!!	Set values of this face equal to those NcY-1 cell in y-direction. Equal and opposite for x-vel. and x-mom.:
!			m=cells(i,j-1,k,mn)
!			qx=+1.d0*cells(i,j-1,k,qxn)
!			qy=-1.d0*cells(i,j-1,k,qyn)
!			qz=+1.d0*cells(i,j-1,k,qzn)
!			E = cells(i,j-1,k,En)
!			rho = cells(i,j-1,k,rhon)
!			ux = +1.d0*cells(i,j-1,k,uxn)
!			uy = -1.d0*cells(i,j-1,k,uyn)
!			uz = +1.d0*cells(i,j-1,k,uzn)
!			p = cells(i,j-1,k,pn)
!			V = cells(i,j-1,k,Vn)
!
!!	Set position of faces equal to those already assigned in Cell Setup:
!			Midx=cells(i,j,k,xn)
!			Midy=cells(i,j,k,yn)
!			Midz=cells(i,j,k,zn)
!!
!!	Set gradients to zero for reflective boundary:
!			grad_d_x= 0.d0
!			grad_d_y=0.d0
!			grad_d_z=0.d0
!			grad_ux_x=0.d0
!			grad_uy_x=0.d0
!			grad_uz_x=0.d0
!			grad_ux_y=0.d0
!			grad_uy_y=0.d0
!			grad_uz_y=0.d0
!			grad_ux_z=0.d0
!			grad_uy_z=0.d0
!			grad_uz_z=0.d0
!			grad_p_x=0.d0
!			grad_p_y=0.d0
!			grad_p_z=0.d0
!
!			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)
!			i=i+1
!		enddo
!		k=k+1
!	enddo
!
!
!==============================================================================
!*****			z-Axis Face Ghost Cells:			  ******
!==============================================================================
!
!!	Face normal to: -ve z-axis
!	i=1
!	j=1
!	k=1
!	Do while(j<=NcY)
!		i=1
!		Do while(i<=NcX)
!
!!	Set values of this face equal to those +2 cell in z-direction. Equal and opposite for x-vel. and x-mom.:
!			m=cells(i,j,k+1,mn)
!			qx=+1.d0*cells(i,j,k+1,qxn)
!			qy=+1.d0*cells(i,j,k+1,qyn)
!			qz=-1.d0*cells(i,j,k+1,qzn)
!			E = cells(i,j,k+1,En)
!			rho = cells(i,j,k+1,rhon)
!			ux = +1.d0*cells(i,j,k+1,uxn)
!			uy = +1.d0*cells(i,j,k+1,uyn)
!			uz = -1.d0*cells(i,j,k+1,uzn)
!			p = cells(i,j,k+1,pn)
!			V = cells(i,j,k+1,Vn)
!
!!	Set position of faces equal to those already assigned in Cell Setup:
!			Midx=cells(i,j,k,xn)
!			Midy=cells(i,j,k,yn)
!			Midz=cells(i,j,k,zn)
!
!!	Set gradients to zero for reflective boundary:
!			grad_d_x= 0.d0
!			grad_d_y=0.d0
!			grad_d_z=0.d0
!			grad_ux_x=0.d0
!			grad_uy_x=0.d0
!			grad_uz_x=0.d0
!			grad_ux_y=0.d0
!			grad_uy_y=0.d0
!			grad_uz_y=0.d0
!			grad_ux_z=0.d0
!			grad_uy_z=0.d0
!			grad_uz_z=0.d0
!			grad_p_x=0.d0
!			grad_p_y=0.d0
!			grad_p_z=0.d0
!
!			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)
!
!			i=i+1
!		enddo
!		j=j+1
!	enddo
!
!!	Face normal to: +ve z-axis
!	i=1
!	j=1dot_product(vector_a, vector_b)
!	k=NcZ
!	Do while(j<=NcY)
!		i=1
!		Do while(i<=NcX)
!
!!	Set values of this face equal to those NcZ-1 cell in z-direction. Equal and opposite for x-vel. and x-mom.:
!			m=cells(i,j,k-1,mn)
!			qx=+1.d0*cells(i,j,k-1,qxn)
!			qy=+1.d0*cells(i,j,k-1,qyn)
!			qz=-1.d0*cells(i,j,k-1,qzn)
!			E = cells(i,j,k-1,En)
!			rho = cells(i,j,k-1,rhon)
!			ux = +1.d0*cells(i,j,k-1,uxn)
!			uy = +1.d0*cells(i,j,k-1,uyn)
!			uz = -1.d0*cells(i,j,k-1,uzn)
!			p = cells(i,j,k-1,pn)
!			V = cells(i,j,k-1,Vn)
!
!!	Set position of faces equal to those already assigned in Cell Setup:
!			Midx=cells(i,j,k,xn)
!			Midy=cells(i,j,k,yn)
!			Midz=cells(i,j,k,zn)
!
!!	Set gradients to zero for reflective boundary:
!			grad_d_x= 0.d0
!			grad_d_y=0.d0
!			grad_d_z=0.d0
!			grad_ux_x=0.d0
!			grad_uy_x=0.d0
!			grad_uz_x=0.d0
!			grad_ux_y=0.d0
!			grad_uy_y=0.d0
!			grad_uz_y=0.d0
!			grad_ux_z=0.d0
!			grad_uy_z=0.d0
!			grad_uz_z=0.d0
!			grad_p_x=0.d0
!			grad_p_y=0.d0
!			grad_p_z=0.d0
!
!			cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)
!
!			i=i+1
!		enddo
!		j=j+1
!	enddo

end subroutine bounds


      SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT)
C
C   PURPOSE:
C      Reduce a submatrix situated in rows and columns LOW through
C      IGH to upper Hesenberg form by stabilized elementary similarity
C      transformations.  The computational method follows that of Martin
C      and Wilkinson.
C
C   REFERENCES:
C      Martin, R.S.; and Wilkinson, J.H.: Similarity Reduction of a
C        General Matrix to Hessenberg Form.  Numer. Math., Bd. 12, Heft
C        5, 1968, pp. 349-368.
C      Wilkinson, J.H.; and Reinsch, C.: Handbook for Automatic Computa-
C        tion.  Volume II - Linear Algebra.  Springer-Verlag, 1971.
C
C   Subroutines employed by ELMHES: None
C   Subroutines employing ELMHES: EIGEN
C
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
      REAL*8 A(NM,N)
      REAL*8 X,Y
C     REAL*8 DABS
      INTEGER INT(IGH)
C
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         MM1 = M - 1
         X = 0.0
         I = M
C
         DO 100 J = M, IGH
            IF (DABS(A(J,MM1)) .LE. DABS(X)) GO TO 100
            X = A(J,MM1)
            I = J
  100    CONTINUE
C
         INT(M) = I
         IF (I .EQ. M) GO TO 130
C    ********** INTERCHANGE ROWS AND COLUMNS OF A **********
         DO 110 J = MM1, N
            Y = A(I,J)
            A(I,J) = A(M,J)
            A(M,J) = Y
  110    CONTINUE
C
         DO 120 J = 1, IGH
            Y = A(J,I)
            A(J,I) = A(J,M)
            A(J,M) = Y
  120    CONTINUE
C    ********** END INTERCHANGE **********
  130    IF (X .EQ. 0.0) GO TO 180
         MP1 = M + 1
C
         DO 160 I = MP1, IGH
            Y = A(I,MM1)
            IF (Y .EQ. 0.0) GO TO 160
            Y = Y / X
            A(I,MM1) = Y
C
            DO 140 J = M, N
  140       A(I,J) = A(I,J) - Y * A(M,J)
C
            DO 150 J = 1, IGH
  150       A(J,M) = A(J,M) + Y * A(J,I)
C
  160    CONTINUE
C
  180 CONTINUE
C
  200 RETURN
C    ********** LAST CARD OF ELMHES **********
      END


program funcExample
  implicit none
  integer :: i
  real, dimension(2) :: a, b
  real :: x
  do i = 1, 2
     x = foo(a(i+1) + a(i))
     != stencil readOnce, forward(depth=1, dim=1) :: a
     b(i) = x
 end do

contains

   real function foo(y)
    real :: y
    foo = y*y
  end function
end program