! Copyright 2022, Francois BOUCHUT, Anne MANGENEY, Marc PERUZZETTO, Antoine LUCAS,  Jacques SAINTE-MARIE
! This program is distributed under the terms of the Lesser GPL v3
! This file is part of SHALTOP.

module flux

  use parameters
  use states
  use topography
  
  implicit double precision (a-h,o-z)

  double precision,dimension(:,:), allocatable :: absvp,frho &
       & ,frhoug,frhoud,frhoutg,frhoutd,feta
  double precision,dimension(:,:), allocatable :: aybsvp,fyrho &
       & ,fyrhous,fyrhoun,fyrhouts,fyrhoutn,fyeta
  
contains

  !Allocate table
  subroutine flux_allocate

    allocate(absvp(0:nx,1:ny),frho(0:nx,1:ny),frhoug(0:nx,1:ny),frhoud(0:nx,1:ny))
    allocate(frhoutg(0:nx,1:ny),frhoutd(0:nx,1:ny),feta(0:nx,1:ny))
    allocate(aybsvp(1:nx,0:ny),fyrho(1:nx,0:ny),fyrhous(1:nx,0:ny),fyrhoun(1:nx,0:ny))
    allocate(fyrhouts(1:nx,0:ny),fyrhoutn(1:nx,0:ny),fyeta(1:nx,0:ny))    
    
  end subroutine flux_allocate

  !----------------------------------------
  
  !Symmetry to dicretize second member
  subroutine sym(p,pt,ph,pth,v,vt,vh,vth)
    double precision,intent(in) :: p,pt,ph,pth,v,vt
    double precision,intent(out) :: vh,vth
    if (isym.eq.1) then
       sq=sqrt(1.d0+p**2+pt**2)
       sqh=sqrt(1.d0+ph**2+pth**2)
       ratio=(v*(p-ph)+vt*(pt-pth))/(1.d0+p*ph+pt*pth+sq*sqh)
       vh=sqh*(v/sq+ratio*(p/sq+ph/sqh))
       vth=sqh*(vt/sq+ratio*(pt/sq+pth/sqh))
    else
       vh=v
       vth=vt
    end if
  end subroutine sym

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

  subroutine flux_estimate_velocity_init
    
    do j=1,ny
       do i=0,nx
          otah=max(otad(i,j),otag(i+1,j))
          ph=.5d0*(pd(i,j)+pg(i+1,j))
          pth=.5d0*(ptd(i,j)+ptg(i+1,j))
          omeg=1.d0+pth**2
          omegt=-ph*pth
          sq=sqrt(1.d0+ph**2+pth**2)
          gdeltaz=grav*delz(i,j)
          gdeltazps=max(0.d0,gdeltaz&
               & -corvide/omeg*max(0.d0,ud(i,j)**2-ug(i+1,j)**2)/2.d0)
          gdeltazms=max(0.d0,-gdeltaz&
               & -corvide/omeg*max(0.d0,ug(i+1,j)**2-ud(i,j)**2)/2.d0)
          rhomoins=(max(0.d0,rhod(i,j)*otad(i,j)&
               &-gdeltazps/(grav))/otah)
          rhoplus=(max(0.d0,rhog(i+1,j)*otag(i+1,j)&
               &-gdeltazms/(grav))/otah)
          call sym(pd(i,j),ptd(i,j),ph,pth,ud(i,j),utd(i,j),ulh,utlh)
          call sym(pg(i+1,j),ptg(i+1,j),ph,pth,ug(i+1,j),utg(i+1,j)&
               & ,urh,utrh)
          call fluxnumer(rhomoins,rhoplus&
               & ,ulh,urh,(omeg*utlh-omegt*ulh)/sq,(omeg*utrh-omegt*urh)/sq&
               & ,ckappa*rhomoins*otah*omeg&
               & ,ckappa*rhoplus*otah*omeg&
               & ,absvp(i,j),frho(i,j),frhouh,frhouth,feta(i,j))
       enddo
    enddo
    do i=1,nx
       do j=0,ny
          otah=max(otan(i,j),otas(i,j+1))
          ph=.5d0*(pn(i,j)+ps(i,j+1))
          pth=.5d0*(ptn(i,j)+pts(i,j+1))
          omegt=1.d0+ph**2
          omeg=-ph*pth
          sq=sqrt(1.d0+ph**2+pth**2)
          gdeltaz=grav*delzy(i,j)
          gdeltazps=max(0.d0,gdeltaz&
               & -corvide/omegt*max(0.d0,utn(i,j)**2-uts(i,j+1)**2)/2.d0)
          gdeltazms=max(0.d0,-gdeltaz&
               & -corvide/omegt*max(0.d0,uts(i,j+1)**2-utn(i,j)**2)/2.d0)
          rhomoins=(max(0.d0,rhon(i,j)*otan(i,j)&
               &-gdeltazps/(grav))/otah)
          rhoplus=(max(0.d0,rhos(i,j+1)*otas(i,j+1)&
               &-gdeltazms/(grav))/otah)
          call sym(ptn(i,j),pn(i,j),pth,ph,utn(i,j),un(i,j),utsh,ush)
          call sym(pts(i,j+1),ps(i,j+1),pth,ph,uts(i,j+1),us(i,j+1)&
               & ,utnh,unh)
          call fluxnumer(rhomoins,rhoplus&
               & ,utsh,utnh,(omegt*ush-omeg*utsh)/sq,(omegt*unh-omeg*utnh)/sq&
               & ,ckappa*rhomoins*otah*omegt&
               & ,ckappa*rhoplus*otah*omegt&
               & ,aybsvp(i,j),fyrho(i,j),fyrhouth,fyrhouh,fyeta(i,j))
       enddo
    enddo

  end subroutine flux_estimate_velocity_init

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

  subroutine flux_compute
    
    do j=1,ny
       do i=0,nx
          otah=max(otad(i,j),otag(i+1,j))
          ph=.5d0*(pd(i,j)+pg(i+1,j))
          pth=.5d0*(ptd(i,j)+ptg(i+1,j))
          omeg=1.d0+pth**2
          omegt=-ph*pth
          sq=sqrt(1.d0+ph**2+pth**2)
          gdeltaz=grav*(delz(i,j)+delb(i,j))
          gdeltazps=max(0.d0,gdeltaz&
               & -corvide/omeg*max(0.d0,ud(i,j)**2-ug(i+1,j)**2)/2.d0)
          gdeltazms=max(0.d0,-gdeltaz&
               & -corvide/omeg*max(0.d0,ug(i+1,j)**2-ud(i,j)**2)/2.d0)
          rhomoins=(max(0.d0,rhod(i,j)*otad(i,j)&
               &-gdeltazps/(grav))/otah)
          rhoplus=(max(0.d0,rhog(i+1,j)*otag(i+1,j)&
               &-gdeltazms/(grav))/otah)
          pil=ckappa*rhod(i,j)**2*otad(i,j)
          pir=ckappa*rhog(i+1,j)**2*otag(i+1,j)
          pilh=ckappa*rhomoins**2*otah
          pirh=ckappa*rhoplus**2*otah
          call sym(pd(i,j),ptd(i,j),ph,pth,ud(i,j),utd(i,j),ulh,utlh)
          call sym(pg(i+1,j),ptg(i+1,j),ph,pth,ug(i+1,j),utg(i+1,j)&
               & ,urh,utrh)
          call fluxnumer(rhomoins,rhoplus&
               & ,ulh,urh,(omeg*utlh-omegt*ulh)/sq,(omeg*utrh-omegt*urh)/sq&
               & ,ckappa*rhomoins*otah*omeg&
               & ,ckappa*rhoplus*otah*omeg&
               & ,absvp(i,j),frho(i,j),frhouh,frhouth,feta(i,j))
          frhouth=(frhouth*sq+omegt*frhouh)/omeg
          call sym(ph,pth,pd(i,j),ptd(i,j)&
               & ,frhouh-omeg*pilh,frhouth-omegt*pilh,frhoulh,frhoutlh)
          call sym(ph,pth,pg(i+1,j),ptg(i+1,j)&
               & ,frhouh-omeg*pirh,frhouth-omegt*pirh,frhourh,frhoutrh)
          if (abs(ud(i,j)).gt.1.d-12) then
             pil=pil+frho(i,j)*(max(0.d0,gdeltaz)-gdeltazps)/ud(i,j)
          endif
          if (abs(ug(i+1,j)).gt.1.d-12) then
             pir=pir+frho(i,j)*(max(0.d0,-gdeltaz)-gdeltazms)/ug(i+1,j)
          endif
          frhoug(i,j)=frhoulh+pil*(1.d0+ptd(i,j)**2)
          frhoud(i,j)=frhourh+pir*(1.d0+ptg(i+1,j)**2)
          frhoutg(i,j)=frhoutlh+pil*(-pd(i,j)*ptd(i,j))
          frhoutd(i,j)=frhoutrh+pir*(-pg(i+1,j)*ptg(i+1,j))
          feta(i,j)=feta(i,j)/omeg+.5d0*abs(gdeltaz)*frho(i,j)
       enddo
    enddo
    do i=1,nx
       do j=0,ny
          otah=max(otan(i,j),otas(i,j+1))
          ph=.5d0*(pn(i,j)+ps(i,j+1))
          pth=.5d0*(ptn(i,j)+pts(i,j+1))
          omegt=1.d0+ph**2
          omeg=-ph*pth
          sq=sqrt(1.d0+ph**2+pth**2)
          gdeltaz=grav*(delzy(i,j)+delby(i,j))
          gdeltazps=max(0.d0,gdeltaz&
               & -corvide/omegt*max(0.d0,utn(i,j)**2-uts(i,j+1)**2)/2.d0)
          gdeltazms=max(0.d0,-gdeltaz&
               & -corvide/omegt*max(0.d0,uts(i,j+1)**2-utn(i,j)**2)/2.d0)
          rhomoins=(max(0.d0,rhon(i,j)*otan(i,j)&
               &-gdeltazps/(grav))/otah)
          rhoplus=(max(0.d0,rhos(i,j+1)*otas(i,j+1)&
               &-gdeltazms/(grav))/otah)
          pis=ckappa*rhon(i,j)**2*otan(i,j)
          pin=ckappa*rhos(i,j+1)**2*otas(i,j+1)
          pish=ckappa*rhomoins**2*otah
          pinh=ckappa*rhoplus**2*otah
          call sym(ptn(i,j),pn(i,j),pth,ph,utn(i,j),un(i,j),utsh,ush)
          call sym(pts(i,j+1),ps(i,j+1),pth,ph,uts(i,j+1),us(i,j+1)&
               & ,utnh,unh)
          call fluxnumer(rhomoins,rhoplus&
               & ,utsh,utnh,(omegt*ush-omeg*utsh)/sq,(omegt*unh-omeg*utnh)/sq&
               & ,ckappa*rhomoins*otah*omegt&
               & ,ckappa*rhoplus*otah*omegt&
               & ,aybsvp(i,j),fyrho(i,j),fyrhouth,fyrhouh,fyeta(i,j))
          fyrhouh=(fyrhouh*sq+omeg*fyrhouth)/omegt
          call sym(pth,ph,ptn(i,j),pn(i,j)&
               & ,fyrhouth-omegt*pish,fyrhouh-omeg*pish,fyrhoutsh,fyrhoush)
          call sym(pth,ph,pts(i,j+1),ps(i,j+1)&
               & ,fyrhouth-omegt*pinh,fyrhouh-omeg*pinh,fyrhoutnh,fyrhounh)
          if (abs(utn(i,j)).gt.1.d-12) then
             pis=pis+fyrho(i,j)*(max(0.d0,gdeltaz)-gdeltazps)/utn(i,j)
          endif
          if (abs(uts(i,j+1)).gt.1.d-12) then
             pin=pin+fyrho(i,j)*(max(0.d0,-gdeltaz)-gdeltazms)/uts(i,j+1)
          endif
          fyrhouts(i,j)=fyrhoutsh+pis*(1.d0+pn(i,j)**2)
          fyrhoutn(i,j)=fyrhoutnh+pin*(1.d0+ps(i,j+1)**2)
          fyrhous(i,j)=fyrhoush+pis*(-ptn(i,j)*pn(i,j))
          fyrhoun(i,j)=fyrhounh+pin*(-pts(i,j+1)*ps(i,j+1))
          fyeta(i,j)=fyeta(i,j)/omegt+.5d0*abs(gdeltaz)*fyrho(i,j)
       enddo
    enddo

  end subroutine flux_compute

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

  !Compute new means for rho, u and ut
  subroutine flux_new_means(ind_time_order)
    integer,intent(in) :: ind_time_order

    do j=1,ny
       do i=1,nx
          if (z(i,j).ne.ndv) then
             r=rho(i,j)-thet(i,j)*sig*(frho(i,j)-frho(i-1,j))&
                  & -thet(i,j)*sigy*(fyrho(i,j)-fyrho(i,j-1))

             !Smooth velocity if r is too small
             r2=states_smooth_velocity(r)
             
             if (r.gt.0.d0) then
                call fluxc(rhog(i,j),rhod(i,j),ug(i,j),ud(i,j),utg(i,j),utd(i,j)&
                     & ,grav*(delzc(i,j)+delbc(i,j)),otag(i,j),otad(i,j)&
                     & ,pg(i,j),pd(i,j),ptg(i,j),ptd(i,j),fluxc1,fluxc2)
                call fluxc(rhos(i,j),rhon(i,j),uts(i,j),utn(i,j),us(i,j),un(i,j)&
                     & ,grav*(delzcy(i,j)+delbcy(i,j)),otas(i,j),otan(i,j)&
                     & ,pts(i,j),ptn(i,j),ps(i,j),pn(i,j),fluxcy2,fluxcy1)
                unew=(rho(i,j)*u(i,j)-thet(i,j)*sig*(frhoug(i,j)-frhoud(i-1,j)&
                     & -fluxc1)-thet(i,j)*sigy*(fyrhous(i,j)-fyrhoun(i,j-1)-fluxcy1))/r2
                utnew=(rho(i,j)*ut(i,j)-thet(i,j)*sig*(frhoutg(i,j)-frhoutd(i-1,j)&
                     &-fluxc2)-thet(i,j)*sigy*(fyrhouts(i,j)-fyrhoutn(i,j-1)-fluxcy2))/r2
                if (max_velocity.gt.0) then
                   call states_correct_vel(unew,utnew,p(i,j),pt(i,j),unew2,utnew2)
                   unew=unew2
                   utnew=utnew2
                endif
             else
                unew=0.d0
                utnew=0.d0
             endif
             dissloc=float(1-(mtordre-1)*(ind_time_order-1))&
                  &*(r2*(unew**2+utnew**2+(p(i,j)*unew+pt(i,j)*utnew)**2)/(1.d0+p(i,j)&
                  & **2+pt(i,j)**2)/2.d0&
                  & +ckappa*r2**gamma*ota(i,j))/thet(i,j)&
                  &-float(1+(mtordre-1)*(2-ind_time_order))&
                  &*(rho(i,j)*(u(i,j)**2+ut(i,j)**2+(p(i,j)*u(i,j)&
                  & +pt(i,j)*ut(i,j))**2)/(1.d0+p(i,j)**2+pt(i,j)**2)/2.d0&
                  & +ckappa*rho(i,j)**gamma*ota(i,j))/thet(i,j)&
                  &+sig*(feta(i,j)-feta(i-1,j)&
                  &+.5d0*grav*delz(i,j)*frho(i,j)+.5d0*grav*delz(i-1,j)*frho(i-1,j)&
                  &+grav*delzc(i,j)*rho(i,j)*u(i,j))&
                  &+sigy*(fyeta(i,j)-fyeta(i,j-1)&
                  &+.5d0*grav*delzy(i,j)*fyrho(i,j)&
                  &+.5d0*grav*delzy(i,j-1)*fyrho(i,j-1)&
                  &+grav*delzcy(i,j)*rho(i,j)*ut(i,j))
             etadiss(i,j)=dissloc/delt
             if (.not.(r.ge.0.)) then
                write(*,"('rho negatif ou infini')")
                write(*,*)'time',temps
                write(*,*)'i,j,',i,j
                write(*,*)'r',r
                write(*,*)'rho ',rho(i,j)
                write(*,*)'thet ',thet(i,j)
                write(*,*)'sig ',sig
                write(*,*)'sigy ',sigy
                write(*,*)'frho ',frho(i,j),' ',frho(i-1,j)
                write(*,*)'fyrho ',fyrho(i,j),' ',fyrho(i,j-1)
                call abort
             endif
             rho(i,j)=r
             u(i,j)=unew
             ut(i,j)=utnew
          else
             rho(i,j)=0.
             u(i,j)=0.
             ut(i,j)=0.
          end if
       enddo
    enddo

  end subroutine flux_new_means

  !---------------------------------------
  
  !Flux at the center of the cell
  subroutine fluxc(rhol,rhor,ul,ur,utl,utr,deltaz,otal,otar,pl,pr ,ptl,ptr,fluxc1,fluxc2)
    double precision,intent(in) :: rhol,rhor,ul,ur,utl,utr,deltaz ,otal,otar,pl,pr,ptl,ptr
    double precision,intent(out) :: fluxc1,fluxc2
    deltazstar=max(-2.d0*gamma/(gamma-1.d0)&
         & *ckappa*rhor**(gamma-1.d0)*otar&
         & ,min(deltaz,2.d0*gamma/(gamma-1.d0)&
         & *ckappa*rhol**(gamma-1.d0)*otal))
    otah=sqrt(otal*otar)
    rhomoins=(max(0.d0,rhol**(gamma-1.d0)*otal-deltazstar/2.d0&
         & /(gamma/(gamma-1.d0)*ckappa))/otah)**(1.d0/(gamma-1.d0))
    rhoplus=(max(0.d0,rhor**(gamma-1.d0)*otar+deltazstar/2.d0&
         & /(gamma/(gamma-1.d0)*ckappa))/otah)**(1.d0/(gamma-1.d0))
    pil=ckappa*rhol**gamma*otal
    pir=ckappa*rhor**gamma*otar
    deltapih=ckappa*(rhoplus**gamma-rhomoins**gamma)*otah
    if (rhol.ne.rhomoins) then
       rhomedlh=(gamma-1.d0)/gamma*(rhomoins**gamma-rhol**gamma)&
            & /(rhomoins**(gamma-1.d0)-rhol**(gamma-1.d0))
    else
       rhomedlh=rhol
    endif
    if (rhor.ne.rhoplus) then
       rhomedrh=(gamma-1.d0)/gamma*(rhoplus**gamma-rhor**gamma)&
            & /(rhoplus**(gamma-1.d0)-rhor**(gamma-1.d0))
    else
       rhomedrh=rhor
    endif
    deltazss=max(-troncdz&
         & *gamma/(gamma-1.d0)*ckappa*rhor**(gamma-1.d0)*otar,min(deltaz&
         & ,troncdz*gamma/(gamma-1.d0)*ckappa*rhol**(gamma-1.d0)*otal))
    deltapih=deltapih+.5d0*(rhomedlh+rhomedrh)*(deltazss-deltazstar)
    ph=.5d0*(pl+pr)
    pth=.5d0*(ptl+ptr)
    call sym(pl,ptl,ph,pth,ul,utl,ulh,utlh)
    call sym(pr,ptr,ph,pth,ur,utr,urh,utrh)
    fluxr=.5d0*(rhol*ul+rhor*ur)
    fluxc1=pir*(1.d0+ptr**2)-pil*(1.d0+ptl**2)-deltapih*(1.d0+pth**2)&
         & +fluxr*(ur-ul+ulh-urh)
    fluxc2=pir*(-pr*ptr)-pil*(-pl*ptl)-deltapih*(-ph*pth)&
         & +fluxr*(utr-utl+utlh-utrh)
  end subroutine fluxc

  !------------------------------------------
  !Numerical flux
  subroutine fluxnumer(rhol,rhor,ul,ur,utl,utr,povrhol,povrhor&
       & ,absvpout,fluxrho,fluxrhou,fluxrhout,fluxeta)
    double precision,intent(in) :: rhol,rhor,ul,ur,utl,utr&
         & ,povrhol,povrhor
    double precision,intent(out) :: absvpout,fluxrho,fluxrhou,fluxrhout&
         & ,fluxeta

    if ((rhol.le.0.d0).and.(rhor.le.0.d0)) then
       absvpout=max(abs(ul),abs(ur))
       fluxrho=0.d0
       fluxrhou=0.d0
       fluxrhout=0.d0
       fluxeta=0.d0
    else
       pl=povrhol*rhol
       pr=povrhor*rhor
       el=povrhol/(gamma-1.d0)
       er=povrhor/(gamma-1.d0)
       if (isimpl.eq.2) then
          sl=sqrt(gamma*povrhol)
          sr=sqrt(gamma*povrhor)
          if (pr-pl.ge.0.d0) then
             al=sl+.5d0*(gamma+1.d0)*max(0.d0,(pr-pl)/rhor/sr+ul-ur)
             if (rhol.gt.0.d0) then
                ar=sr+.5d0*(gamma+1.d0)*max(0.d0,(pl-pr)/rhol/al+ul-ur)
             else
                ar=sr
             endif
          else
             ar=sr+.5d0*(gamma+1.d0)*max(0.d0,(pl-pr)/rhol/sl+ul-ur)
             if (rhor.gt.0.d0) then
                al=sl+.5d0*(gamma+1.d0)*max(0.d0,(pr-pl)/rhor/ar+ul-ur)
             else
                al=sl
             endif
          endif
       else
          al=arelax(rhol,rhor,ul,ur,povrhol,povrhor)
          ar=al
       endif
       cl=al*rhol
       cr=ar*rhor
       if (al.gt.0.d0) then
          povcl=povrhol/al
       else
          povcl=0.d0
       endif
       if (ar.gt.0.d0) then
          povcr=povrhor/ar
       else
          povcr=0.d0
       endif
       !cvaleurs propres
       vp1=ul-al
       utmp=(cl*ul+cr*ur-(pr-pl))/(cl+cr)
       vp3=ur+ar
       absvpout=max(abs(vp1),abs(vp3))
       !csuivant l'etat intermediaire
       if (vp1.ge.0.d0) then
          fluxrho=rhol*ul
          fluxrhou=rhol*ul*ul+pl
          fluxrhout=rhol*utl*ul
          fluxeta=(rhol*(ul**2/2.d0+utl**2/2.d0+el)+pl)*ul
       else if (utmp.ge.0) then
          rhotmp=cl/(al+(cr*(ur-ul)-(pr-pl))/(cl+cr))
          pisovcl=(cr*povcl+pr-cr*(ur-ul))/(cl+cr)
          es=el-.5d0*povcl**2+.5d0*pisovcl**2
          fluxrho=rhotmp*utmp
          fluxrhou=rhotmp*utmp*utmp+pisovcl*cl
          fluxrhout=rhotmp*utl*utmp
          fluxeta=(rhotmp*(utmp**2/2.d0+utl**2/2.d0+es)+pisovcl*cl)*utmp
       else if (vp3.ge.0.d0) then
          rhotmp=cr/(ar+(cl*(ur-ul)+(pr-pl))/(cl+cr))
          pisovcr=(pl+cl*povcr-cl*(ur-ul))/(cl+cr)
          es=er-.5d0*povcr**2+.5d0*pisovcr**2
          fluxrho=rhotmp*utmp
          fluxrhou=rhotmp*utmp*utmp+pisovcr*cr
          fluxrhout=rhotmp*utr*utmp
          fluxeta=(rhotmp*(utmp**2/2.d0+utr**2/2.d0+es)+pisovcr*cr)*utmp
       else
          fluxrho=rhor*ur
          fluxrhou=rhor*ur*ur+pr
          fluxrhout=rhor*utr*ur
          fluxeta=(rhor*(ur**2/2.d0+utr**2/2.d0+er)+pr)*ur
       endif
       if ((.not.(fluxrho.ge.0)).and.(.not.(fluxrho.le.0))) then
          write(*,*)'error in fluxnumer'
          write(*,*)'fluxrho',fluxrho
          write(*,*)'vp1',vp1
          write(*,*)'rhol',rhol
          write(*,*)'utmp',utmp
          write(*,*)'cl+cr',cl+cr
          write(*,*)'vp3',vp3
          write(*,*)'ar',ar
          write(*,*)'al',al
          write(*,*)'cl',cl
          write(*,*)'cr',cr
          write(*,*)'ul',ul
          write(*,*)'ur',ur
          write(*,*)'pl',pl
          write(*,*)'pr',pr
          call abort
       end if
       !write(*,*) 'fluxrho',fluxrho
       !write(*,*) 'cl+cr',cl+cr
    endif
  end subroutine fluxnumer

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

  !Velocity for boundary flux imposed
  function vitfluxentr(rhol,rhor,fluxin,ur,povrhol,povrhor)

    if ((rhol.le.0.d0).and.(rhor.le.0.d0)) then
       vitfluxentr=0.d0
    else
       pl=povrhol*rhol
       pr=povrhor*rhor
       if (rhol.gt.0.d0) then
          ul=fluxin/rhol
       else
          ul=0.d0
       endif
       do iter=1,3
          if (isimpl.eq.2) then
             sl=sqrt(gamma*povrhol)
             sr=sqrt(gamma*povrhor)
             if (pr-pl.ge.0.d0) then
                al=sl+.5d0*(gamma+1.d0)*max(0.d0,(pr-pl)/rhor/sr+ul-ur)
                if (rhol.gt.0.d0) then
                   ar=sr+.5d0*(gamma+1.d0)*max(0.d0,(pl-pr)/rhol/al+ul-ur)
                else
                   ar=sr
                endif
             else
                ar=sr+.5d0*(gamma+1.d0)*max(0.d0,(pl-pr)/rhol/sl+ul-ur)
                if (rhor.gt.0.d0) then
                   al=sl+.5d0*(gamma+1.d0)*max(0.d0,(pr-pl)/rhor/ar+ul-ur)
                else
                   al=sl
                endif
             endif
          else
             a=arelax(rhol,rhor,ul,ur,povrhol,povrhor)
             al=a
             ar=al
          endif
          cl=al*rhol
          cr=ar*rhor
          ul=(fluxin*al*(cl+cr)+(fluxin-cl)*(cr*ur+pl-pr))/(cl**2+cr*fluxin)
       enddo
       vitfluxentr=ul
    endif
  end function vitfluxentr

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

  function arelax(rhol,rhor,ul,ur,povrhol,povrhor)
    implicit double precision (a-h,o-z)

    pl=povrhol*rhol
    pr=povrhor*rhor
    a=sqrt(max(gamma*povrhol,gamma*povrhor))
    if ((rhol.le.0.d0).and.(rhor.le.0.d0)) then
       arelax=a
    else
       !ccontrainte gauche
       cpovrhol=(gamma*povrhol)**(1.d0/(gamma+1.d0))
       c1g=rhor/(rhol+rhor)*(ur-ul)
       c2g=-(pr-pl)/(rhol+rhor)
       phin=1.+c1g/a+c2g/a**2-cpovrhol/a**(2.d0/(gamma+1.d0))
       if (phin.lt.0.d0) then
          a=a+max(0.d0,-c1g)/(2.d0*(3.d0*gamma+1.d0)/(gamma+1.d0)**2)
          phin=1.d0+c1g/a+c2g/a**2-cpovrhol/a**(2.d0/(gamma+1.d0))
          phiprn=2.d0+c1g/a&
               & -2.d0*gamma/(gamma+1.d0)*cpovrhol/a**(2.d0/(gamma+1.d0))
          a=a*(1.d0-phin/phiprn)
          do while (abs(phin/phiprn).gt.1.d-3)
             phin=1.d0+c1g/a+c2g/a**2-cpovrhol/a**(2.d0/(gamma+1.d0))
             phiprn=2.d0+c1g/a-2.d0*gamma/(gamma+1.d0)&
                  & *cpovrhol/a**(2.d0/(gamma+1.d0))
             a=a*(1.d0-phin/phiprn)
          enddo
       endif
       !ccontrainte droite
       cpovrhor=(gamma*povrhor)**(1.d0/(gamma+1.d0))
       c1d=rhol/(rhol+rhor)*(ur-ul)
       c2d=(pr-pl)/(rhol+rhor)
       phin=1.d0+c1d/a+c2d/a**2-cpovrhor/a**(2.d0/(gamma+1.d0))
       if (phin.lt.0.d0) then
          a=a+max(0.d0,-c1d)/(2.d0*(3.d0*gamma+1.d0)/(gamma+1.d0)**2)
          phin=1.d0+c1d/a+c2d/a**2-cpovrhor/a**(2.d0/(gamma+1.d0))
          phiprn=2.d0+c1d/a-2.d0*gamma/(gamma+1.d0)&
               & *cpovrhor/a**(2.d0/(gamma+1.d0))
          a=a*(1.d0-phin/phiprn)
          do while (abs(phin/phiprn).gt.1.d-3)
             phin=1.d0+c1d/a+c2d/a**2-cpovrhor/a**(2.d0/(gamma+1.d0))
             phiprn=2.d0+c1d/a-2.d0*gamma/(gamma+1.d0)&
                  & *cpovrhor/a**(2.d0/(gamma+1.d0))
             a=a*(1.d0-phin/phiprn)
          enddo
       endif
       arelax=a
    endif
  end function arelax

end module flux
