module hydrosolver

  ! Module for Capreole (f90)
  ! Author: Garrelt Mellema
  ! Date: 2004-05-11

  ! This module contains the Roe solver for solving the Euler equations
  ! in two dimensions on a curvilinear grid, including advected quantities.
  !
  ! The implementation is in the `fluctuations' form of LeVeque.
  ! It includes the transverse waves for improved 2D performance as an option.
  ! The Euler quantities use `flux reconstruction', with stationary
  ! extrapolation for the geometric source terms.

  ! The main routine is split into many subroutines for readability
  ! and to aid the compiler.

  ! This version has routines for constructing and destructing the arrays
  ! needed for the solver, since otherwise they would be placed on the
  ! stack, which can cause problems.

  use precision, only: dp
  use sizes, only: nrOfDim,neq,neuler,mbc,RHO,EN
  use atomic, only: gamma1
  !use geometry

  implicit none

  private

  real(kind=dp),parameter,private    :: HALF=0.5d0 ! 1/2
  real(kind=dp),parameter,private    :: ONE=1.0d0  ! 1
  real(kind=dp),parameter,private    :: ZERO=0.0d0 ! 0

  ! Number of waves
  integer,parameter,private :: nwaves=5    ! number of waves

  ! Limiters
  integer,parameter,private :: NO_LIMITER=0
  integer,parameter,private :: MON_CEN=1
  integer,parameter,private :: VAN_LEER=2
  integer,parameter,private :: SUPERBEE=3
  integer,parameter,private :: USE_LIMITER=SUPERBEE

  ! Transverse wave directions
  integer,parameter,private :: RIGHT=0
  integer,parameter,private :: LEFT=-1

  ! The following variables are public so that they can be filled
  ! or used outside of the solver. They correspond to the one
  ! spatial dimension
  real(kind=dp),dimension(:,:),allocatable,public :: state1d
  ! volume times pressure
  real(kind=dp),dimension(:),allocatable,public :: wp
  ! dstate will contain the state changes:
  real(kind=dp),dimension(:,:),allocatable,public :: dstate
  !$OMP THREADPRIVATE(state1d,wp,dstate)

  ! The following variables are private since they are only
  ! needed inside the solver.
  real(kind=dp),dimension(:,:),allocatable :: w ! parameter vector

  real(kind=dp),dimension(:,:),allocatable :: fluxc ! central flux at i
  real(kind=dp),dimension(:,:),allocatable :: fluxl ! left flux at i-1/2
  real(kind=dp),dimension(:,:),allocatable :: fluxr ! right flux at i-1/2
  real(kind=dp),dimension(:,:),allocatable :: fludif ! flux difference at i-1/2
  real(kind=dp),dimension(:,:),allocatable :: stadif ! state difference at i-1/2
  !$OMP THREADPRIVATE(w,fluxc,fluxl,fluxr,fludif,stadif)

  real(kind=dp),dimension(:),allocatable :: rrt  ! 1/rho average
  real(kind=dp),dimension(:,:),allocatable :: vt ! roe average velocity 2
  real(kind=dp),dimension(:),allocatable :: ht ! roe average enthalpy
  real(kind=dp),dimension(:),allocatable :: absvt  ! absolute velocity
  real(kind=dp),dimension(:),allocatable :: vst2    ! sound speed squared
  real(kind=dp),dimension(:),allocatable :: vst   ! sound speed
  !$OMP THREADPRIVATE(rrt,vt,ht,absvt,vst2,vst)

  real(kind=dp),dimension(:,:),allocatable :: eiglam ! eigen values/characteristics
  real(kind=dp),dimension(:,:),allocatable :: sgn ! sign of eigenvalues

  real(kind=dp),dimension(:,:,:),allocatable :: eigv

  real(kind=dp),dimension(:),allocatable :: uvdif ! inner product of v and
  real(kind=dp),dimension(:,:),allocatable :: a ! projection coefficient

  real(kind=dp),dimension(:,:,:),allocatable :: wave
  real(kind=dp),dimension(:,:,:),allocatable :: adq
  real(kind=dp),dimension(:,:),allocatable :: flux  ! 2nd order correction
  !$OMP THREADPRIVATE(eiglam,sgn,eigv,uvdif,a,wave,adq,flux)

  public :: constr_solver, destr_solver, solver

contains

  !============================================================================
  subroutine constr_solver (mesh)

    integer,intent(in) :: mesh

    ! Initializes solver variables

    allocate(state1d(1-mbc:mesh+mbc,neq))
    allocate(wp(1-mbc:mesh+mbc))
    allocate(dstate(1-mbc:mesh+mbc,neq))

    allocate(w(1-mbc:mesh+mbc,neuler))
    allocate(fluxc(1-mbc:mesh+mbc,neuler))
    allocate(fluxl(2-mbc:mesh+mbc,neuler))
    allocate(fluxr(2-mbc:mesh+mbc,neuler))
    allocate(fludif(2-mbc:mesh+mbc,neuler))
    allocate(stadif(2-mbc:mesh+mbc,neq))

    allocate(rrt(2-mbc:mesh+mbc))
    allocate(vt(2-mbc:mesh+mbc,nrOfDim))
    allocate(ht(2-mbc:mesh+mbc))
    allocate(absvt(2-mbc:mesh+mbc))
    allocate(vst2(2-mbc:mesh+mbc))
    allocate(vst(2-mbc:mesh+mbc))

    allocate(eiglam(2-mbc:mesh+mbc,nwaves))
    allocate(sgn(2-mbc:mesh+mbc,nwaves))

    allocate(eigv(2-mbc:mesh+mbc,neq,nwaves))

    allocate(uvdif(2-mbc:mesh+mbc))
    allocate(a(2-mbc:mesh+mbc,nwaves))

    allocate(wave(2-mbc:mesh+mbc,neuler,nwaves))
    allocate(adq(2-mbc:mesh+mbc,neq,LEFT:RIGHT))
    allocate(flux(2-mbc:mesh+mbc,neq))

  end subroutine constr_solver

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

  subroutine destr_solver

    ! Destructs solver variables

    deallocate(state1d)
    deallocate(wp)
    deallocate(dstate)

    deallocate(w)
    deallocate(fluxc)
    deallocate(fluxl)
    deallocate(fluxr)
    deallocate(fludif)
    deallocate(stadif)

    deallocate(rrt)
    deallocate(vt)
    deallocate(ht)
    deallocate(absvt)
    deallocate(vst2)
    deallocate(vst)

    deallocate(eiglam)
    deallocate(sgn)

    deallocate(eigv)

    deallocate(uvdif)
    deallocate(a)

    deallocate(wave)
    deallocate(adq)
    deallocate(flux)

  end subroutine destr_solver

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

  subroutine solver (mesh,dt,dx,dy,dz,V1,V2,V3,ij,ik,ierror)

    ! The central Roe solver routine, supplies dstate (normal and transverse
    ! state changes)

    ! parameters
    ! small    - a small number
    ! nwaves   - number of waves

    integer,intent(in) :: mesh
    real(kind=dp),intent(in) :: dt,dx,dy,dz
    integer,intent(in) :: ij,ik
    integer,intent(in) :: V1,V2,V3 ! indices of the the two velocities:
                                        ! V1: integration direction
                                        ! V2,V3: perpendicular direction
    integer,intent(out) :: ierror ! control integer

    integer :: i,ieq,mw
    real(kind=dp) :: dtdx!,dtdy

    ! smooth transition through zero characteristics
    !real(kind=dp) :: fctr
    ! steepness of transition function
    !real(kind=dp),dimension(nwaves) :: beta= (/ 1d4, 1d4, 1d4, 1d4 /)

    !real(kind=dp) :: rhol,rhor,ul,ur
    !real(kind=dp),dimension(2-mbc:mesh+mbc)   :: utadv

    integer :: ipres_error

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

    ierror=0 ! initialise the control variable to 0
    ipres_error=0

    call initialize ()

    ! ---------------------------------------------------------------------
    ! Part 1: Roe solver
    ! ---------------------------------------------------------------------

    call calculate_parametervector ()

    call calculate_fluxes ()

    call stationary_extrapolation ()

    call calculate_differences ()

    call calculate_roe_averages (ierror)

    ! Only continue if we have a sound speed
    error: if (ierror == 0) then

       call calculate_jacobian (V1-1,V2-1,V3-1)

       call calculate_projection_coeffs (V1-1,V2-1,V3-1,stadif)

       call split_waves (stadif,adq)

       call flux_limiting (USE_LIMITER)

       call calculate_state_change ()

       ipres_error=pressure_fix ()

       ! Find final change in state
       dstate(1:mesh,1:neq)=dtdx*dstate(1:mesh,1:neq)

    endif error

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

  contains

    !--------------------------------------------------------------------------
    subroutine initialize

      ! Note: ifc 7.1 has a bug and does not map the flux
      ! adq, amq, and dstate arrays properly to this internal
      ! subroutine. Result: run time error "Adress Error"
      ! Fix:
      ! 1) compile with -auto (this triggers other errors)
      ! 2) compile with -g

      ! Initialize some arrays to zero

      dstate=ZERO
      adq=ZERO
      flux=ZERO

    end subroutine initialize

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

    subroutine calculate_parametervector

      ! ----------------------------------------------------------------------
      ! find the parameter-vector w from the state.
      ! The state should already contain the volume terms.
      !
      ! 1 <-> sqrt(vol)*sqrt(rho)
      ! 2 <-> sqrt(vol)*sqrt(rho)*u
      ! 3 <-> sqrt(vol)*sqrt(rho)*v
      ! 4 <-> sqrt(vol)*sqrt(rho)*enthalpy
      ! wp<-> vol*pressure (is imported)
      ! ----------------------------------------------------------------------
      w(:,RHO)=sqrt(state1d(:,RHO))
      w(:,V1)=state1d(:,V1)/w(:,RHO)
      w(:,V2)=state1d(:,V2)/w(:,RHO)
      w(:,V3)=state1d(:,V3)/w(:,RHO)
      w(:,EN)=(state1d(:,EN)+wp(:))/w(:,RHO)

    end subroutine calculate_parametervector

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

    subroutine calculate_fluxes

      ! ---------------------------------------------------------------------
      ! calculate the fluxes at the cell centre
      ! ---------------------------------------------------------------------
      do i=1-mbc,mesh+mbc
         fluxc(i,RHO)=w(i,V1)*w(i,RHO)
         fluxc(i,V1)=w(i,V1)*w(i,V1) + wp(i)
         fluxc(i,V2)=w(i,V1)*w(i,V2)
         fluxc(i,V3)=w(i,V1)*w(i,V3)
         fluxc(i,EN)=w(i,V1)*w(i,EN)
      enddo

    end subroutine calculate_fluxes

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

    subroutine stationary_extrapolation ()

      ! ---------------------------------------------------------------------
      ! calculate the fluxes at the cell walls, using
      ! `stationary extrapolation'
      ! ---------------------------------------------------------------------
      do ieq=1,neuler
         do i=2-mbc,mesh+mbc
            fluxl(i,ieq)=fluxc(i-1,ieq)
            fluxr(i,ieq)=fluxc(i,ieq)
         enddo
      enddo

    end subroutine stationary_extrapolation

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

    subroutine calculate_differences ()

      ! calculate the state differences at the cell walls.
      ! index i corresponds to i-1/2 (left cell well of cell i).
      do ieq=1,neq
         do i=2-mbc,mesh+mbc
            stadif(i,ieq)=state1d(i,ieq)-state1d(i-1,ieq)
         enddo
      enddo
      ! ---------------------------------------------------------------------
      ! calculate the flux differences at the cell walls
      ! ---------------------------------------------------------------------
      !do ieq=1,neuler
      !   do i=2-mbc,mesh+mbc
      !      fludif(i,ieq)=fluxr(i,ieq)-fluxl(i,ieq)
      !   enddo
      !enddo

      ! ---------------------------------------------------------------------
      ! calculate the state differences at the cell walls
      ! (for the advected quantities)
      ! ---------------------------------------------------------------------
      !do ieq=neuler+1,neq
      !   do i=2-mbc,mesh+mbc
      !      stadif(i,ieq)=state1d(i,ieq)-state1d(i-1,ieq)
      !   enddo
      !enddo

    end subroutine calculate_differences

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

    subroutine calculate_roe_averages (ierror)

      integer,intent(out) :: ierror

      ! calculate Roe averages
      do i=2-mbc,mesh+mbc
         rrt(i)=ONE/(w(i-1,RHO)+w(i,RHO))
         vt(i,V1-1)=(w(i-1,V1)+w(i,V1))*rrt(i) ! velocity
         vt(i,V2-1)=(w(i-1,V2)+w(i,V2))*rrt(i) ! velocity
         vt(i,V3-1)=(w(i-1,V3)+w(i,V3))*rrt(i) ! velocity
         ht(i)=(w(i-1,EN)+w(i,EN))*rrt(i)       ! enthalpy
      enddo

      ! absolute velocity
      absvt(:)=HALF*(vt(:,1)*vt(:,1)+vt(:,2)*vt(:,2)+vt(:,3)*vt(:,3))

      ! sound speed
      vst2(:)=gamma1*(ht(:)-absvt(:))

      do i=2-mbc,mesh+mbc
         ! check for negative values of vst2
         if (vst2(i) > 0.0) then
            vst(i)=sqrt(vst2(i))
         else
            vst(i)=sqrt(abs(vst2(i)))
            ierror=ierror+1
            write(30,*) 'VST2 neagtive: ',i,ij,ik,vst2(i),V1,V2,V3
            write(30,*) 'velocity: ',vt(i-1:i,1:3)
            write(30,*) 'pressure: ',wp(i-1:i)
            !stop                       ! negative vst2 is fatal!
         endif
      enddo

    end subroutine calculate_roe_averages

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

    subroutine calculate_jacobian (itr,ip1,ip2)

      ! Calculates the eigenvalues and eigenvectors of the Jacobian
      ! for the coordinate direction itr.
      ! The results are eiglam and eigv

      ! itr  - index of transverse direction we are considering
      ! ip1  - index of first parallel direction
      ! ip2  - index of second parallel direction

      integer :: itr,ip1,ip2

      ! calculate the eigenvalues and vectors of the jacobian

      eiglam(:,1)=vt(:,itr)-vst(:)
      eiglam(:,2)=vt(:,itr)
      eiglam(:,3)=vt(:,itr)+vst(:)
      eiglam(:,4)=vt(:,itr)
      eiglam(:,5)=vt(:,itr)

      eigv(:,RHO,1:3)=ONE    ! density
      eigv(:,RHO,4:5)=ZERO

      ! shift velocity indices to state indices
      eigv(:,itr+1,1)=vt(:,itr)-vst(:)
      eigv(:,itr+1,2)=vt(:,itr)
      eigv(:,itr+1,3)=vt(:,itr)+vst(:)
      eigv(:,itr+1,4:5)=ZERO

      eigv(:,ip1+1,1)=vt(:,ip1)
      eigv(:,ip1+1,2)=vt(:,ip1)
      eigv(:,ip1+1,3)=vt(:,ip1)
      eigv(:,ip1+1,4)=ONE
      eigv(:,ip1+1,5)=ZERO

      eigv(:,ip2+1,1)=vt(:,ip2)
      eigv(:,ip2+1,2)=vt(:,ip2)
      eigv(:,ip2+1,3)=vt(:,ip2)
      eigv(:,ip2+1,4)=ZERO
      eigv(:,ip2+1,5)=ONE

      eigv(:,EN,1)=ht(:)-vt(:,itr)*vst(:) ! energy
      eigv(:,EN,2)=absvt(:)
      eigv(:,EN,3)=ht(:)+vt(:,itr)*vst(:)
      eigv(:,EN,4)=vt(:,ip1)
      eigv(:,EN,5)=vt(:,ip2)

    end subroutine calculate_jacobian

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

    subroutine calculate_projection_coeffs (itr,ip1,ip2,q)

      ! Projects the quantity q onto the eigenvectors of the Jacobian

      ! itr  - index of transverse direction we are considering (x=1, y=2, z=3)
      ! ip1   - index of first parallel direction
      ! ip2   - index of second parallel direction
      ! q     - quantity to project

      integer :: itr,ip1,ip2
      real(kind=dp),dimension(2-mbc:mesh+mbc,neq) :: q

      real(kind=dp),dimension(2-mbc:mesh+mbc) ::  vdotq

      ! calculate the projection of q onto the eigenvectors

      vdotq(:)=vt(:,itr)*q(:,itr+1)+vt(:,ip1)*q(:,ip1+1)+vt(:,ip2)*q(:,ip2+1)

      do i=2-mbc,mesh+mbc
         a(i,1)=HALF*(gamma1*(absvt(i)*q(i,RHO)+q(i,EN)-vdotq(i))- &
              vst(i)*(q(i,itr+1)-vt(i,itr)*q(i,RHO)))/(vst2(i))
         a(i,2)=gamma1*((ht(i)-2.0d0*absvt(i))*q(i,RHO)+ &
              vdotq(i)-q(i,EN))/(vst(i)*vst(i))
         a(i,3)=HALF*(gamma1*(absvt(i)*q(i,RHO)+q(i,EN)-vdotq(i))+ &
              vst(i)*(q(i,itr+1)-vt(i,itr)*q(i,RHO)))/(vst2(i))
         a(i,4)=q(i,ip1+1)-vt(i,ip1)*q(i,RHO)
         a(i,5)=q(i,ip2+1)-vt(i,ip2)*q(i,RHO)
      enddo

    end subroutine calculate_projection_coeffs

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

    subroutine split_waves (q,splitq)

      ! ---------------------------------------------------------------------
      ! Calculate the waves and divide them into left and right going
      ! (first order solution).
      !
      ! There may be cases where a smoother transition than this step
      ! function is better, this avoids problems with expansion points
      ! (entropy fix) and perhaps odd-even decoupling. The commented
      ! out lines do a transition using an arctan function.
      ! ---------------------------------------------------------------------

      real(kind=dp),dimension(2-mbc:mesh+mbc,neq) :: q
      real(kind=dp),dimension(2-mbc:mesh+mbc,neq,LEFT:RIGHT) :: splitq

      ! put splitq to zero
      splitq(:,:,:)=ZERO

      ! For the Euler quantities
      do ieq=1,neuler
         do i=2-mbc,mesh+mbc
            do mw=1,nwaves
               wave(i,ieq,mw)=a(i,mw)*eigv(i,ieq,mw)
               splitq(i,ieq,LEFT)=splitq(i,ieq,LEFT)+ &
                    min(eiglam(i,mw),ZERO)*wave(i,ieq,mw)
               splitq(i,ieq,RIGHT)=splitq(i,ieq,RIGHT)+ &
                    max(eiglam(i,mw),ZERO)*wave(i,ieq,mw)
            enddo
         enddo
      enddo

      ! For the advected quantities
      do ieq=neuler+1,neq
         do i=2-mbc,mesh+mbc
            splitq(i,ieq,LEFT)=splitq(i,ieq,LEFT) + &
                 min(eiglam(i,4),ZERO)*q(i,ieq)
            splitq(i,ieq,RIGHT)=splitq(i,ieq,RIGHT) + &
                 max(eiglam(i,4),ZERO)*q(i,ieq)
         enddo
      enddo

    end subroutine split_waves

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

    subroutine flux_limiting (limfunc)

      ! Calculates the second order fluxes, using a limiter

      real(kind=dp),parameter ::  small=1.0d-24 ! small number

      integer,intent(in) :: limfunc

      integer :: isb

      real(kind=dp) :: wnorm2,wip,r,philim

      ! ---------------------------------------------------------------------
      ! apply the fluxcorrection to make 2nd order correction fluxes
      !
      ! This comes from LeVeque: take the inner product of the wave and
      ! the upwind wave and compare this with the absolute value of the
      ! wave. Since they are vectors, this is a better way to compare
      ! them.
      ! ---------------------------------------------------------------------
      dtdx=dt/dx
      ! Set flux to zero
      flux(:,:)=ZERO

      ! For each wave, find the limiter using the ratio of the
      ! inner product of the waves
      do mw=1,nwaves
         do i=1,mesh+1

            ! Find out whether to look left or right (for individual waves)
            if (eiglam(i,mw).lt.ZERO) then
               isb=i+1
            else
               isb=i-1
            endif

            ! calculate inner products (more accurate)
            wip=dot_product(wave(isb,1:neuler,mw),wave(i,1:neuler,mw))
            wnorm2=dot_product(wave(i,1:neuler,mw),wave(i,1:neuler,mw))

            ! calculate the ratio
            if (wnorm2.lt.small) then
               r=ZERO
            else
               r=wip/wnorm2
            endif

            ! Limiter
            philim = limiter(r,limfunc)

            ! set the 2nd order correction term flux
            do ieq=1,neuler
               flux(i,ieq)=flux(i,ieq)+ &
                    abs(eiglam(i,mw))*(ONE-dtdx*abs(eiglam(i,mw)))* &
                    philim*wave(i,ieq,mw)
            enddo
         enddo
      enddo

      ! Limit the advective fluxes:
      !   eiglam is the velocity (eiglam(4))
      !   for accuracy take the minimum of all philim values

      do i=1,mesh+1
         philim=2.0d0

         ! Find out whether to look left or right (for individual waves)
         if (eiglam(i,4).lt.ZERO) then
            isb=i+1
         else
            isb=i-1
         endif

         ! calculate the ratio
         do ieq=neuler+1,neq
            if (abs(stadif(i,ieq)).lt.1e-25) then
               r=2.0d0
            else
               r=stadif(isb,ieq)/stadif(i,ieq)
            endif

            ! Limiter
            philim=min(philim,limiter(r,limfunc))
         enddo

         ! set the 2nd order correction term flux
         do ieq=neuler+1,neq
            flux(i,ieq)=abs(eiglam(i,4))* &
                 (ONE-dtdx*abs(eiglam(i,4)))*philim*stadif(i,ieq)
         enddo
      enddo

    end subroutine flux_limiting

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

    function limiter(ratio,limfunc)

      ! Limiter function used in flux limiting.
      ! It limits a ratio using the function limfunc.

      real(kind=dp) :: limiter

      ! superbee parameter (1 to 2)
      real(kind=dp),parameter :: sbpar=1.8

      real(kind=dp),intent(in) :: ratio
      integer,intent(in) :: limfunc

      real(kind=dp) :: c

      select case (limfunc)
      case (NO_LIMITER)
         limiter = ZERO
      case(MON_CEN)
         ! monotinized centered
         c = (1.d0 + ratio)/2.d0
         limiter = max(0.d0, min(c, 2.d0, 2.d0*ratio))
      case(VAN_LEER)
         ! van Leer
         limiter = (ratio + abs(ratio)) / (1.d0 + abs(ratio))
      case(SUPERBEE)
         ! Superbee (sbpar)
         limiter = max(ZERO,min(ONE,sbpar*ratio),min(sbpar,ratio))
         !!philim = min(philim,max(ZERO, min(ONE, sbpar*r), min(sbpar, r)))
      end select

    end function limiter

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

    subroutine calculate_state_change

      ! calculate the change in state (1st and 2nd order added)
      do ieq=1,neq
         do i=1,mesh
            dstate(i,ieq)=-adq(i,ieq,RIGHT)-adq(i+1,ieq,LEFT) &
                 +HALF*(flux(i,ieq)-flux(i+1,ieq))
         enddo
      enddo

    end subroutine calculate_state_change

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

    function pressure_fix ()

      ! ---------------------------------------------------------------------
      ! This routines checks whether the new solution will have positive
      ! pressure, density and energy density. If not two fixes are tried:
      ! 1) drop all the second order terms (flux)
      ! 2) add some diffusion
      !
      ! There is an issue with problems spreading after having fixed a
      ! point. It is necessary to search again for bad points in the
      ! neighbourhood after having fixed one point.
      ! ---------------------------------------------------------------------

      integer :: pressure_fix

      ! Coefficient of the diffusion
      real(kind=dp),parameter :: eta=0.0001

      real(kind=dp),dimension(mesh) :: ptest      ! negative pressure tests
      real(kind=dp),dimension(mesh) :: ptest2
      real(kind=dp),dimension(mesh) :: ptest3
      real(kind=dp),dimension(1-mbc:mesh+mbc,neq) :: diff

      integer :: imin

      pressure_fix=0
      diff(:,:)=ZERO

      ! ---------------------------------------------------------------------
      ! calculate test variable for negative pressure check
      ! Note: this check is not full proof since it does not incorporate
      ! the transverse fluxes
      ! ---------------------------------------------------------------------
      do i=1,mesh
         ptest(i)=prestest(i)
      enddo

      ! ---------------------------------------------------------------------
      ! check for negative pressure/internal energy/density and set change
      ! in state to first order if detected
      ! ---------------------------------------------------------------------
      p1loop: do i=1,mesh
         prtest1: if (ptest(i) <= ZERO .or.                         &
              (dx*state1D(i,EN)+dt*dstate(i,EN)) <= ZERO .or.      &
              (dx*state1D(i,RHO)+dt*dstate(i,RHO)) <= ZERO) then

            !!write(30,*) 'Roe solver: ptest1 failed: ', i,ij,V1,V2

            ! Set 2nd order fluxes to zero at the interfaces of i
            ! Recalculate dstate for i-1,i,i+1
            do ieq=1,neq
               flux(i,ieq)=ZERO
               flux(i+1,ieq)=ZERO
               dstate(i-1,ieq)=-adq(i-1,ieq,RIGHT)-adq(i,ieq,LEFT)+ &
                    HALF*flux(i-1,ieq)
               dstate(i,ieq)=-adq(i,ieq,RIGHT)-adq(i+1,ieq,LEFT)
               dstate(i+1,ieq)=-adq(i+1,ieq,RIGHT)-adq(i+2,ieq,LEFT)- &
                    HALF*flux(i+2,ieq)
            enddo

            ! Recalculate ptest for new dstate of i+1
            ! Do not do this if we are at the boundary
            if (i < mesh) ptest(i+1)=prestest(i+1)

            ! Recalculate ptest for new dstate of i-1 and below and fix
            ! if needed.
            ! Do not do this if the cell was already flagged
            ! and if we are at the boundary
            imin=i-1
            backward1: do
               okbefore1: if (imin >= 1 .and. ptest(imin) > zero .and.        &
                    (dx*state1D(imin,EN)+dt*dstate(imin,EN)) > zero .and.     &
                    (dx*state1D(imin,RHO)+dt*dstate(imin,RHO)) > zero) then
                  ptest(imin)=prestest(imin)
                  badnow1: if (ptest(imin) <= ZERO .or.                       &
                       (dx*state1D(imin,EN)+dt*dstate(imin,EN)) <= ZERO .or.  &
                       (dx*state1D(imin,RHO)+dt*dstate(imin,RHO)) <= ZERO) then
                     !write(30,*) 'Roe solver: ptest1 back correction: ', &
                     !     imin,ij,V1,V2
                     do ieq=1,neq
                        flux(imin,ieq)=0.0
                        dstate(imin-1,ieq)=-adq(imin-1,ieq,RIGHT)- &
                             adq(imin,ieq,LEFT) + HALF*flux(imin-1,ieq)
                        dstate(imin,ieq)=-adq(imin-1,ieq,RIGHT)- &
                             adq(imin,ieq,LEFT)
                     enddo
                  else
                     exit
                  endif badnow1
               else
                  exit
               endif okbefore1
               imin=imin-1
            end do backward1

         end if prtest1
      end do p1loop

      ! Check if it helped, set control variable if not
      do i=1,mesh
         ptest2(i)=prestest(i)
      enddo

      ! ---------------------------------------------------------------------
      ! check for negative pressure/internal energy/density and add diffusion
      ! if detected
      ! ---------------------------------------------------------------------
      p2loop: do i=1,mesh
         prtest2: if (ptest2(i) <= ZERO .or.                               &
              (dx*state1D(i,EN)+dt*dstate(i,EN)) <= ZERO .or.      &
              (dx*state1D(i,RHO)+dt*dstate(i,RHO)) <= ZERO) then
            !!write(30,*) 'Roe solver: ptest2 failed: ', i,ij,V1,V2
            do ieq=1,neq
               diff(i,ieq)=eta*(state1D(i-1,ieq)-state1D(i,ieq))/dtdx
               diff(i+1,ieq)=eta*(state1D(i,ieq)-state1D(i+1,ieq))/dtdx
               dstate(i-1,ieq)=-adq(i-1,ieq,RIGHT)-adq(i,ieq,LEFT)+ &
                    HALF*(flux(i-1,ieq)-flux(i,ieq))+        &
                    diff(i-1,ieq)-diff(i,ieq)
               dstate(i,ieq)=-adq(i,ieq,RIGHT)-adq(i+1,ieq,LEFT)+ &
                    HALF*(flux(i,ieq)-flux(i+1,ieq))+      &
                    diff(i,ieq)-diff(i+1,ieq)
               dstate(i+1,ieq)=-adq(i+1,ieq,RIGHT)-adq(i+2,ieq,LEFT)+ &
                    HALF*(flux(i+1,ieq)-flux(i+2,ieq))+        &
                    diff(i+1,ieq)-diff(i+2,ieq)
            enddo

            ! Recalculate ptest for new dstate of i+1
            ! Do not do this if we are at the boundary
            if (i < mesh) ptest2(i+1)=prestest(i+1)

            ! Recalculate ptest for new dstate of i-1 and below and fix
            ! if needed.
            ! Do not do this if the cell was already flagged
            ! and if we are at the boundary
            imin=i-1
            backward2: do
               okbefore2: if (imin >= 1 .and. ptest2(imin) > zero .and.       &
                    (dx*state1D(imin,EN)+dt*dstate(imin,EN)) > zero .and.     &
                    (dx*state1D(imin,RHO)+dt*dstate(imin,RHO)) > zero) then
                  ptest2(imin)=prestest(imin)
                  badnow2: if (ptest2(imin) <= ZERO .or.                     &
                       (dx*state1D(imin,EN)+dt*dstate(imin,EN)) <= ZERO .or. &
                       (dx*state1D(imin,RHO)+dt*dstate(imin,RHO)) <= ZERO) then
                     !write(30,*) 'Roe solver: ptest2 back correction: ', &
                     !     imin,ij,V1,V2
                     do ieq=1,neq
                        diff(imin,ieq)=eta*(state1D(imin-1,ieq)-       &
                             state1D(imin,ieq))/dtdx
                        dstate(imin-1,ieq)=-adq(imin-1,ieq,RIGHT)- &
                             adq(imin,ieq,LEFT)-                     &
                             diff(imin,ieq) +                        &
                             HALF*(flux(imin-1,ieq)-flux(imin,ieq))
                        dstate(imin,ieq)=-adq(imin,ieq,RIGHT)-     &
                             adq(imin+1,ieq,LEFT)+                   &
                             diff(imin,ieq)+                         &
                             HALF*(flux(imin,ieq)-flux(imin+1,ieq))
                     enddo
                  else
                     exit
                  endif badnow2
               else
                  exit
               endif okbefore2
               imin=imin-1
            enddo backward2
         endif prtest2
      enddo p2loop

      ! Check if it helped, set control variable if not
      do i=1,mesh
         ptest3(i)=prestest(i)
      enddo
      do i=1,mesh
         if (ptest3(i) <= ZERO .or.                                &
              (dx*state1D(i,EN)+dt*dstate(i,EN)) <= ZERO .or.      &
              (dx*state1D(i,RHO)+dt*dstate(i,RHO)) <= ZERO) then
            !write(30,*) 'Roe solver: ptest3 failed: ', i,ij,V1,V2
            pressure_fix=pressure_fix+1
         endif
      enddo

    end function pressure_fix

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

    function prestest(i)

      ! Pressure test function
      ! Calculates the new pressure times a constant, to allow
      ! checking the sign of the new pressure in pressure_fix.

      real(kind=dp) :: prestest

      integer,intent(in) :: i

      prestest=2.0d0*(dx*state1D(i,EN)+dt*dstate(i,EN))*                  &
            (dx*state1D(i,RHO)+dt*dstate(i,RHO))-                         &
            (dx*state1D(i,V1)+dt*dstate(i,V1))**2-  &
            (dx*state1D(i,V2)+dt*dstate(i,V2))**2-  &
            (dx*state1D(i,V3)+dt*dstate(i,V3))**2

    end function prestest

  end subroutine solver

end module hydrosolver


module rep_ker
implicit none
real*8, parameter :: dk26f1 = 1.0d0/14.0d0, dk26f2 = 1.0d0/18.0d0, &
dk24f1 = 2.0d0/15.0d0, dk24f2 = 2.0d0/21.0d0, dk25f1 = 2.0d0/21.0d0,&
dk25f2 = 1.0d0/14.0d0, akf1=2.0d0/3.0d0

contains

function drker24(x,xi)
implicit none
real*8, intent(in) :: x, xi
real*8 :: drker24, xl, xs

xl = x
xs = xi
if (x .lt. xi) then
  xl = xi
  xs = x
end if

drker24 = dk24f1/xl**5 - dk24f2*xs/xl**6

end function drker24

function ddrker24(x,xi)
implicit none
real*8, intent(in) :: x, xi
real*8 :: ddrker24, xl, xs

if (x .lt. xi) then
  ddrker24 = -dk24f2/xi**6
else
  ddrker24 = -5.0d0*dk24f1/x**6 + 6.0d0*dk24f2*xi/x**7
end if

end function ddrker24

function drker25(x,xi)
implicit none
real*8, intent(in) :: x, xi
real*8 :: drker25, xl, xs

xl = x
xs = xi
if (x .lt. xi) then
  xl = xi
  xs = x
end if

drker25 = dk25f1/xl**6 - dk25f2*xs/xl**7

end function drker25

function ddrker25(x,xi)
implicit none
real*8, intent(in) :: x, xi
real*8 :: ddrker25, xl, xs

if (x .lt. xi) then
  ddrker25 = -dk25f2/xi**7
else
  ddrker25 = -6.0d0*dk25f1/x**7 + 7.0d0*dk25f2*xi/x**8
end if

end function ddrker25

function drker26(x,xi)
implicit none
real*8, intent(in) :: x, xi
real*8 :: drker26, xl, xs

xl = x
xs = xi
if (x .lt. xi) then
  xl = xi
  xs = x
end if

drker26 = dk26f1/xl**7 - dk26f2*xs/xl**8

end function drker26

function ddrker26(x,xi)
implicit none
real*8, intent(in) :: x, xi
real*8 :: ddrker26, xl, xs

if (x .lt. xi) then
  ddrker26 = -dk26f2/xi**8
else
  ddrker26 = -7.0d0*dk26f1/x**8 + 8.0d0*dk26f2*xi/x**9
end if

end function ddrker26

function atker23(x,xi)
implicit none
real*8, intent(in) :: x, xi
real*8 :: atker23, xl, xs

xl = x
xs = xi
if (x .lt. xi) then
  xl = xi
  xs = x
end if

atker23 = 1.0d0 + xs*xl + 2.0d0*xs**2*xl  - akf1*xs**3

end function atker23

function datker23(x,xi)
implicit none
real*8, intent(in) :: x, xi
real*8 :: datker23, xl, xs

if (x .lt. xi) then
  datker23 = xi + 4.0d0*x*xi  - 3.0d0*akf1*x**2
else
  datker23 = xi + 2.0d0*xi**2
end if

end function datker23

end module rep_ker

module surface1
implicit none
real*8, allocatable, dimension(:,:) :: asy_array1, asy_array2, & !asy_array3, &
darray1, darray2!, darray3
integer :: na1, na2, nda1, nda2

contains
subroutine pes3d(r12,r23,r31,totener,dvdr)
implicit none
real*8,parameter ::  m2 = 15.99491462d0, m3 = m2, m1 =12.00000000d0
real*8, intent(in) :: r12, r23, r31
real*8, dimension(:), intent(out) :: dvdr(3)
real*8, intent(out) :: totener
real*8 :: capr, theta
real*8, dimension(:,:) :: derv(3,3), deri(3,3), dw(3,3)
real*8, dimension(:) :: derj(3), w(3), ener(3), r(3), m(3), bigr(3)

!      3
!      O
!     / \
!  r3/   \r2
!   /     \
!  /       \
! C---------O
! 1   r1    2

!=====================================================
!
!PES1
!        3
!        O
!  r3   /
!      /  r2
!     /THETA
!C___/_____O
!1   r1    2
!
!

    r(1)=r12
    r(2)=r23
    r(3)=r31
    m(1) = m1
    m(2) = m2
    m(3) = m3
    call crdtrf(r,m,capr,theta,derv)
    call calcener(capr,r12,theta, ener(1), derj, 1)
    ener(1)=ener(1)+0.08072566764673417d0

    deri(1,1) = derj(1)*derv(1,1) + derj(2)*derv(2,1) + derj(3)*derv(3,1)
    deri(1,2) = derj(1)*derv(1,2) + derj(2)*derv(2,2) + derj(3)*derv(3,2)
    deri(1,3) = derj(1)*derv(1,3) + derj(2)*derv(2,3) + derj(3)*derv(3,3)

     dvdr(1) = deri(1,1)
     dvdr(2) = deri(1,2)
     dvdr(3) = deri(1,3)
    totener = ener(1)

end subroutine pes3d

subroutine crdtrf(r,m,capr,theta, derv)
implicit none
real*8, dimension(:), intent(in) :: r(3), m(3)
real*8, dimension(:,:), intent(out) :: derv(3,3)
real*8, intent(out) :: capr, theta
real*8, parameter :: pc = sqrt(epsilon(1.0d0))
real*8 :: cmu1, cmu2, rcm1, rcm2

!        3
!       /|\
!      / | \
!   r3/ R|  \r2
!    /   |th \
!   /____|____\
!  1    r1    2

cmu1 = m(2) / (m(1)+m(2))
cmu2 = m(1) / (m(1)+m(2))

rcm1 = r(1) * cmu1
rcm2 = r(1) * cmu2

capr = sqrt (r(2)**2/r(1)*rcm1 + r(3)**2/r(1)*rcm2 - rcm1*rcm2 )
if (abs(capr) < pc) capr = pc

theta = (rcm2**2+capr**2-r(2)**2)/2.0d0/rcm2/capr
theta=min(1.0d0,max(-1.0d0,theta))

theta = acos(theta)
if (theta==acos(-1.d0)) then
        !nprint*,"shite"
        theta=theta-1.d-5
end if
derv(1,1) = -cmu1*cmu2*r(1)/capr   !dR/dr1

derv(1,2) = r(2)*cmu1/capr !dR/dr2

derv(1,3) = r(3)*cmu2/capr

derv(2,1) = 1.0d0
derv(2,2) = 0.0d0
derv(2,3) = 0.0d0

derv(3,1) = (derv(1,1)/capr*cos(theta)+cos(theta)/r(1)-(capr*derv(1,1)+rcm2*cmu2)/rcm2/capr)&
            /sqrt(1.0d0-cos(theta)**2)

derv(3,2) = (r(2)/rcm2/capr-derv(1,2)/rcm2+cos(theta)/capr*derv(1,2))/sqrt(1.0d0-cos(theta)**2)

derv(3,3) = (cos(theta)/capr*derv(1,3)-derv(1,3)/rcm2)/sqrt(1.0d0-cos(theta)**2)

return

end subroutine crdtrf

subroutine calcener(capr,smlr,theta, ener, der, sno)
use rep_ker
use RKHS            ! This module needs to be used by your code
!use param
implicit none
real*8 :: lambda
real*8, intent(out) :: ener
real*8, intent(in) :: capr, smlr, theta
integer, intent(in) :: sno
real*8, dimension(:), intent(out) :: der(3)
real*8,parameter :: pi = acos(-1.0d0), piby180 = pi/180.0d0
real*8 :: asener, anener, asder, z1, z2
real*8, dimension(:) :: ander(3), x(3)
integer :: kk, ii
type(kernel), save  :: pes11 !pes12!, pes13           ! The kernel type is needed to set up and evaluate a RKHS model
logical, save :: stored = .false., kread = .false.
logical, save :: ker1 = .false., ker2 = .false.!, ker3 = .false.
character (len=80), save :: datapath="./"

if (.not. ker1) then
  inquire(file=trim(datapath)//"pes11_ht.kernel", exist=ker1)   ! file_exists will be true if the file exists and false otherwise
end if

lambda=0.1d-19

if (.not. stored ) then

open(unit=1001,file=trim(datapath)//"asymp.coeff", status = "old")

read(1001,*)na1
allocate(asy_array1(na1,2))
do ii = 1, na1
  read(1001,*)asy_array1(ii,1), asy_array1(ii,2)
end do

read(1001,*)nda1
allocate(darray1(nda1,2))
do ii = 1, nda1
  read(1001,*)darray1(ii,1), darray1(ii,2)
end do

stored = .true.

end if

if (.not. kread) then
if (ker1) then
  call pes11%load_from_file(trim(datapath)//"pes11_ht.kernel")
  kread = .true.
else
  call pes11%read_grid(trim(datapath)//"pes11_ht.csv")
!  print*,"IAMHERE"
  call pes11%k1d(1)%init(TAYLOR_SPLINE_N2_KERNEL)         ! choose one-dimensional kernel for dimension 1
  call pes11%k1d(2)%init(RECIPROCAL_POWER_N2_M6_KERNEL)   ! choose one-dimensional kernel for dimension 2
  call pes11%k1d(3)%init(RECIPROCAL_POWER_N2_M6_KERNEL)

  call pes11%calculate_coefficients_fast()
  call pes11%calculate_sums()
  call pes11%save_to_file(trim(datapath)//"pes11_ht.kernel")
  kread = .true.
end if
end if

x(1)=(1.0d0-cos(theta))/2.0d0
x(2)=capr
x(3)=smlr

if (sno==1) then
  asener = 0.0d0
  asder=0.0d0
  do kk = 1,na1
    asener = asener + drker26(smlr,asy_array1(kk,1))*asy_array1(kk,2)
    asder = asder + ddrker26(smlr,asy_array1(kk,1))*asy_array1(kk,2)
  end do

  anener = 0.0d0
  ander=0.0d0
  call pes11%evaluate_fast(x,anener,ander)

    ener = asener+anener
    der(1) = ander(2)
    der(2) = asder+ander(3)
    der(3) = ander(1)*sin(theta)/2.0d0
end if

return

end subroutine calcener

end module

module callpot1

contains

subroutine co21appes(tmpr, totener, dvdr)
use surface1
implicit none
real*8, dimension (:), intent (in) :: tmpr(3)
real*8, dimension (:), intent (out) :: dvdr(3)
real*8, intent (out) :: totener
real*8, dimension (:) :: dvdx(4),xp(3), tmpdvdr(3), r(3)
real*8, parameter :: dx = 0.005d0
real*8 :: d0h, d02h,ener
integer :: ii

!      3
!      O
!     / \
!  r3/   \r2
!   /     \
!  /       \
! C---------O
! 1   r1    2

r(1) = tmpr(1)
r(2) = tmpr(2)
r(3) = tmpr(3)

call pes3d(r(1),r(2),r(3),totener,dvdr)
if (any(isNaN(dvdr))) then

  do ii = 1, 3

!==========================================================
!   Forward difference to calculate first derivative      =
!==========================================================

    xp=r
    xp(ii)=r(ii)-2.0d0*dx
    call pes3d(xp(1),xp(2),xp(3),ener,tmpdvdr)
    dvdx(1)=ener

    xp=r
    xp(ii)=r(ii)-dx
    call pes3d(xp(1),xp(2),xp(3),ener,tmpdvdr)
    dvdx(2)=ener

    xp=r
    xp(ii)=r(ii)+dx
    call pes3d(xp(1),xp(2),xp(3),ener,tmpdvdr)
    dvdx(3)=ener

    xp=r
    xp(ii)=r(ii)+2.0d0*dx
    call pes3d(xp(1),xp(2),xp(3),ener,tmpdvdr)
    dvdx(4)=ener

    d0h=(dvdx(3)-dvdx(2))/2.0d0/dx
    d02h=(dvdx(4)-dvdx(1))/4.0d0/dx
    dvdr(ii)=(4.0d0*d0h-d02h)/3.0d0
end do
end if
return

end subroutine co21appes

subroutine diatco(r,ener,der)
use surface1
use rep_ker
implicit none
real*8, intent(in) :: r
real*8, intent(out) :: ener, der
integer :: kk

ener=0.0d0
der=0.0d0
do kk = 1, nda1
    ener = ener + drker26(r,darray1(kk,1))*darray1(kk,2)
    der = der + ddrker26(r,darray1(kk,1))*darray1(kk,2)
end do

return

end subroutine diatco

end module


      SUBROUTINE TB01VY( APPLY, N, M, L, THETA, LTHETA, A, LDA, B, LDB,
     $                   C, LDC, D, LDD, X0, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To convert the linear discrete-time system given as its output
C     normal form [1], with parameter vector THETA, into the state-space
C     representation (A, B, C, D), with the initial state x0.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     APPLY   CHARACTER*1
C             Specifies whether or not the parameter vector should be
C             transformed using a bijective mapping, as follows:
C             = 'A' : apply the bijective mapping to the N vectors in
C                     THETA corresponding to the matrices A and C;
C             = 'N' : do not apply the bijective mapping.
C             The transformation performed when APPLY = 'A' allows
C             to get rid of the constraints norm(THETAi) < 1, i = 1:N.
C             A call of the SLICOT Library routine TB01VD associated to
C             a call of TB01VY must use the same value of APPLY.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L >= 0.
C
C     THETA   (input) DOUBLE PRECISION array, dimension (LTHETA)
C             The leading N*(L+M+1)+L*M part of this array must contain
C             the parameter vector that defines a system (A, B, C, D),
C             with the initial state x0. The parameters are:
C
C             THETA(1:N*L)                      : parameters for A, C;
C             THETA(N*L+1:N*(L+M))              : parameters for B;
C             THETA(N*(L+M)+1:N*(L+M)+L*M)      : parameters for D;
C             THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0.
C
C     LTHETA  INTEGER
C             The length of array THETA.  LTHETA >= N*(L+M+1)+L*M.
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array contains the system
C             state matrix corresponding to the output normal form with
C             parameter vector THETA.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array contains the system
C             input matrix corresponding to the output normal form with
C             parameter vector THETA.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading L-by-N part of this array contains the system
C             output matrix corresponding to the output normal form with
C             parameter vector THETA.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,L).
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading L-by-M part of this array contains the system
C             input/output matrix corresponding to the output normal
C             form with parameter vector THETA.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,L).
C
C     X0      (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the initial state of the system, x0,
C             corresponding to the output normal form with parameter
C             vector THETA.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= N*(N+L+1).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The parameters characterizing A and C are used to build N
C     orthogonal transformations, which are then applied to recover
C     these matrices.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Oct. 2000, during a stay at University of Twente, NL.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001,
C     Feb. 2002, Feb. 2004.
C
C     KEYWORDS
C
C     Asymptotically stable, output normal form, parameter estimation,
C     similarity transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, HALF
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 )
C     .. Scalar Arguments ..
      CHARACTER         APPLY
      INTEGER           INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M,
     $                  N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), THETA(*), X0(*)
C     .. Local Scalars ..
      DOUBLE PRECISION  FACTOR, RI, TI, TOBYPI
      INTEGER           CA, JWORK, I, IN, J, K, LDCA
      LOGICAL           LAPPLY
C     .. External Functions ..
      EXTERNAL          DNRM2, LSAME
      DOUBLE PRECISION  DNRM2
      LOGICAL           LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DGER, DLACPY, DSCAL,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ATAN, MAX, SQRT
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      LAPPLY = LSAME( APPLY, 'A' )
C
      INFO = 0
      IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN
         INFO = -1
      ELSEIF ( N.LT.0 ) THEN
         INFO = -2
      ELSEIF ( M.LT.0 ) THEN
         INFO = -3
      ELSEIF ( L.LT.0 ) THEN
         INFO = -4
      ELSEIF ( LTHETA.LT.( N*( L + M + 1 ) + L*M ) ) THEN
         INFO = -6
      ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN
         INFO = -12
      ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN
         INFO = -14
      ELSEIF ( LDWORK.LT.N*( N + L + 1 ) ) THEN
         INFO = -17
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TB01VY', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( MAX( N, M, L ).EQ.0 )
     $   RETURN
C
      IF ( M.GT.0 ) THEN
C
C        Copy the matrix B from THETA.
C
         CALL DLACPY( 'Full', N, M, THETA(N*L+1), N, B, LDB )
C
C        Copy the matrix D.
C
         CALL DLACPY( 'Full', L, M, THETA(N*(L+M)+1), L, D, LDD )
      ENDIF
C
      IF ( N.EQ.0 ) THEN
         RETURN
      ELSE IF ( L.EQ.0 ) THEN
         CALL DCOPY( N, THETA(N*M+1), 1, X0, 1 )
         RETURN
      END IF
C
C     Initialize the indices in the workspace.
C
      LDCA = N + L
C
      CA = 1
C
      JWORK  = CA + N*LDCA
      TOBYPI = HALF/ATAN( ONE )
C
C     Generate the matrices C and A from their parameters.
C     Start with the block matrix [0; I], where 0 is a block of zeros
C     of size L-by-N, and I is the identity matrix of order N.
C
      DWORK(CA) = ZERO
      CALL DCOPY( N*(L+N), DWORK(CA), 0, DWORK(CA), 1 )
      DWORK(CA+L) = ONE
      CALL DCOPY( N, DWORK(CA+L), 0, DWORK(CA+L), LDCA+1 )
C
C     Now, read out THETA(1 : N*L) and perform the transformations
C     defined by the parameters in THETA.
C
      DO 30 I = N, 1, -1
C
C        Save THETAi in the first column of C and use the copy for
C        further processing.
C
         CALL DCOPY( L, THETA((I-1)*L+1), 1, C, 1 )
         TI = DNRM2( L, C, 1 )
         IF ( LAPPLY .AND. TI.NE.ZERO ) THEN
C
C           Apply the bijective mapping which guarantees that TI < 1.
C
            FACTOR = TOBYPI*ATAN( TI )/TI
C
C           Scale THETAi and apply the same scaling on TI.
C
            CALL DSCAL( L, FACTOR, C, 1 )
            TI = TI*FACTOR
         END IF
C
C        RI = sqrt( 1 - TI**2 ).
C
         RI = SQRT( ( ONE - TI )*( ONE + TI ) )
C
C        Multiply a certain part of DWORK(CA) with Ui' from the left,
C        where Ui = [ -THETAi, Si; RI, THETAi' ] is (L+1)-by-(L+1), but
C        Ui is not stored.
C
         CALL DGEMV( 'Transpose', L, N, -ONE, DWORK(CA+N-I), LDCA, C, 1,
     $               ZERO, DWORK(JWORK), 1 )
C
         IF ( TI.GT.ZERO ) THEN
            CALL DGER( L, N, (ONE-RI)/TI/TI, C, 1, DWORK(JWORK), 1,
     $                 DWORK(CA+N-I), LDCA )
         ELSE
C
C           The call below is for the limiting case.
C
            CALL DGER( L, N, HALF, C, 1, DWORK(JWORK), 1,
     $                 DWORK(CA+N-I), LDCA )
         ENDIF
C
         CALL DGER( L, N, ONE, C, 1, DWORK(CA+N-I+L), LDCA,
     $              DWORK(CA+N-I), LDCA )
         CALL DAXPY( N, RI, DWORK(CA+N-I+L), LDCA, DWORK(JWORK), 1 )
C
C        Move these results to their appropriate locations.
C
         DO 20 J = 1, N
            IN = CA + N - I + ( J - 1 )*LDCA
            DO 10 K = IN + L, IN + 1, -1
               DWORK(K) = DWORK(K-1)
   10       CONTINUE
            DWORK(IN) = DWORK(JWORK+J-1)
   20    CONTINUE
C
   30 CONTINUE
C
C     Now, DWORK(CA) = [C; A]. Copy to C and A.
C
      DO 40 I = 1, N
         CALL DCOPY( L, DWORK(CA+(I-1)*LDCA),   1, C(1,I), 1 )
         CALL DCOPY( N, DWORK(CA+L+(I-1)*LDCA), 1, A(1,I), 1 )
   40 CONTINUE
C
C     Copy the initial state x0.
C
      CALL DCOPY( N, THETA(N*(L+M)+L*M+1), 1, X0, 1 )
C
      RETURN
C
C *** Last line of TB01VY ***
      END


! { dg-do run }
! PR46328 - complex expressions involving typebound operators of class objects.
!
module field_module
  implicit none
  type ,abstract :: field
  contains
    procedure(field_op_real) ,deferred :: multiply_real
    procedure(field_plus_field) ,deferred :: plus
    procedure(assign_field) ,deferred :: assn
    generic :: operator(*) => multiply_real
    generic :: operator(+) => plus
    generic :: ASSIGNMENT(=) => assn
  end type
  abstract interface
    function field_plus_field(lhs,rhs)
      import :: field
      class(field) ,intent(in)  :: lhs
      class(field) ,intent(in)  :: rhs
      class(field) ,allocatable :: field_plus_field
    end function
  end interface
  abstract interface
    function field_op_real(lhs,rhs)
      import :: field
      class(field) ,intent(in)  :: lhs
      real ,intent(in) :: rhs
      class(field) ,allocatable :: field_op_real
    end function
  end interface
  abstract interface
    subroutine assign_field(lhs,rhs)
      import :: field
      class(field) ,intent(OUT)  :: lhs
      class(field) ,intent(IN)  :: rhs
    end subroutine
  end interface
end module

module i_field_module
  use field_module
  implicit none
  type, extends (field)  :: i_field
    integer :: i
  contains
    procedure :: multiply_real => i_multiply_real
    procedure :: plus => i_plus_i
    procedure :: assn => i_assn
  end type
contains
  function i_plus_i(lhs,rhs)
    class(i_field) ,intent(in)  :: lhs
    class(field) ,intent(in)  :: rhs
    class(field) ,allocatable :: i_plus_i
    integer :: m = 0
    select type (lhs)
      type is (i_field); m = lhs%i
    end select
    select type (rhs)
      type is (i_field); m = rhs%i + m
    end select
    allocate (i_plus_i, source = i_field (m))
  end function
  function i_multiply_real(lhs,rhs)
    class(i_field) ,intent(in)  :: lhs
    real ,intent(in) :: rhs
    class(field) ,allocatable :: i_multiply_real
    integer :: m = 0
    select type (lhs)
      type is (i_field); m = lhs%i * int (rhs)
    end select
    allocate (i_multiply_real, source = i_field (m))
  end function
  subroutine i_assn(lhs,rhs)
    class(i_field) ,intent(OUT)  :: lhs
    class(field) ,intent(IN)  :: rhs
    select type (lhs)
      type is (i_field)
        select type (rhs)
          type is (i_field)
            lhs%i = rhs%i
        end select
      end select
    end subroutine
end module

program main
  use i_field_module
  implicit none
  class(i_field) ,allocatable :: u
  allocate (u, source = i_field (99))

  u = (u)*2.
  u = (u*2.0*4.0) + u*4.0
  u = u%multiply_real (2.0)*4.0
  u = i_multiply_real (u, 2.0) * 4.0

  select type (u)
    type is (i_field); if (u%i .ne. 152064) call abort
  end select
end program


      double precision function DRANU()
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DRANU Krogh  Changes to use M77CON
c>> 1994-06-24 DRANU CLL Changed common to use RANC[D/S]1 & RANC[D/S]2.
c>> 1992-03-16 CLL
c>> 1991-11-26 CLL Reorganized common. Using RANCM[A/D/S].
c>> 1991-11-22 CLL Added call to RAN0, and DGFLAG in common.
c>> 1991-01-15 CLL Reordered common contents for efficiency.
C>> 1990-01-23 CLL  Making names in common same in all subprogams.
C>> 1987-04-22 DRANU  Lawson  Initial code.
c        Returns one pseudorandom number from the uniform distribution
c        on [0., 1.].
c     C. L. Lawson & S. Y. Chiu, JPL, Apr 1987.
c     ------------------------------------------------------------------
c--D replaces "?": ?RANU, ?RANUA, RANC?1, RANC?2, ?PTR, ?NUMS, ?GFLAG
C     RANCD1 and RANCD2 are common blocks.
c     Calls RAN0 to initialize DPTR and DGFLAG.
c     ------------------------------------------------------------------
      integer M
      parameter(M = 97)
      double precision DNUMS(M)
      common/RANCD2/DNUMS
c
      integer DPTR
      logical DGFLAG
      common/RANCD1/DPTR, DGFLAG
      save  /RANCD1/, /RANCD2/, FIRST
      logical FIRST
      data    FIRST / .true. /
c     ------------------------------------------------------------------
      if(FIRST) then
         FIRST = .false.
         call RAN0
      endif
c
      DPTR = DPTR - 1
      if(DPTR .eq. 0) then
         call DRANUA(DNUMS, M)
         DPTR = M
      endif
      DRANU = DNUMS(DPTR)
      return
      end