! 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 topography

  use parameters, only : nx, ny, initz, delx, dely, theta0, theta1 &
       , grillex, grilley, stvenant
  use init_functions
  use read_files

  implicit double precision (a-h,o-z)

  !Topography
  double precision, dimension(:,:), allocatable :: z
  double precision, dimension(:,:), allocatable :: zg,zd,zs,zn
  double precision, dimension(:,:), allocatable :: delz,delzy,delzc,delzcy
  double precision, dimension(:,:), allocatable :: delb,delby,delbc,delbcy
  double precision, dimension(:,:), allocatable :: p,pt,sp,spt
  double precision, dimension(:,:), allocatable :: thet,ota
  double precision, dimension(:,:), allocatable :: pg,pd,ps,pn
  double precision, dimension(:,:), allocatable :: ptg,ptd,pts,ptn
  double precision, dimension(:,:), allocatable :: thetg,thetd,thets,thetn
  double precision, dimension(:,:), allocatable :: otag,otad,otas,otan    
  double precision, dimension(:,:), allocatable :: Hxx, Hyy, Hxy
  double precision, dimension(:,:), allocatable :: courbn
  
contains

  !Allocate space for arrays-------------------------------------------------------
  subroutine topography_allocate_tables
    allocate (z(0:nx+1,0:ny+1))
    allocate (zg(0:nx+1,0:ny+1),zd(0:nx+1,0:ny+1),zs(0:nx+1,0:ny+1),zn(0:nx+1,0:ny+1))
    allocate (pg(0:nx+1,0:ny+1),pd(0:nx+1,0:ny+1),ps(0:nx+1,0:ny+1),pn(0:nx+1,0:ny+1))
    allocate (ptg(0:nx+1,0:ny+1),ptd(0:nx+1,0:ny+1),pts(0:nx+1,0:ny+1),ptn(0:nx+1,0:ny+1))
    allocate (thetg(0:nx+1,0:ny+1),thetd(0:nx+1,0:ny+1),thets(0:nx+1,0:ny+1),thetn(0:nx+1,0:ny+1))
    allocate (otag(0:nx+1,0:ny+1),otad(0:nx+1,0:ny+1),otas(0:nx+1,0:ny+1),otan(0:nx+1,0:ny+1))
    allocate (delzc(0:nx+1,0:ny+1),delzcy(0:nx+1,0:ny+1),delz(0:nx+1,0:ny+1),delzy(0:nx+1,0:ny+1))
    allocate (delb(0:nx+1,0:ny+1),delby(0:nx+1,0:ny+1),delbc(0:nx+1,0:ny+1),delbcy(0:nx+1,0:ny+1))
    allocate (p(0:nx+1,0:ny+1),pt(0:nx+1,0:ny+1))
    allocate (sp(0:nx+1,0:ny+1),spt(0:nx+1,0:ny+1))
    allocate (thet(0:nx+1,0:ny+1),ota(0:nx+1,0:ny+1))
    allocate (Hxx(0:nx+1,0:ny+1),Hyy(0:nx+1,0:ny+1),Hxy(0:nx+1,0:ny+1))
    allocate (courbn(0:nx+1,0:ny+1))
  end subroutine topography_allocate_tables

  !Write topography from input parameters--------------------------------------------
  subroutine topography_init

    if (initz.eq.0) then
       call read_file(file_z_init,z)
    else
       z=z0()
    end if
    
  end subroutine topography_init

  !Topography gradient and slope---------------------------------------------
  subroutine topography_gradient

    model_type:select case (stvenant)
    case(0)
       !Topography gradient
       do j=0,ny+1
          do i=1,nx
             dz=(z(i+1,j)-z(i-1,j))/4.d0
             p(i,j)=2.d0*dz/delx
          enddo
          p(0,j)=(1.5d0*(z(1,j)-z(0,j))-.5d0*(z(2,j)-z(1,j)))/delx
          p(nx+1,j)=(1.5d0*(z(nx+1,j)-z(nx,j))  -.5d0*(z(nx,j)-z(nx-1,j)))/delx
       enddo
       do i=0,nx+1
          do j=1,ny
             dyz=(z(i,j+1)-z(i,j-1))/4.d0
             pt(i,j)=2.d0*dyz/dely
          enddo
          pt(i,0)=(1.5d0*(z(i,1)-z(i,0))-.5d0*(z(i,2)-z(i,1)))/dely
          pt(i,ny+1)=(1.5d0*(z(i,ny+1)-z(i,ny))  -.5d0*(z(i,ny)-z(i,ny-1)))/dely
       enddo

       !Topography slope
       do j=0,ny+1
          do i=0,nx+1
             thet(i,j)=1.d0/sqrt(1.d0+p(i,j)**2+pt(i,j)**2)
             ota(i,j)=thet(i,j)
          enddo
       enddo

       !Gradient normalization
       do j=0,ny+1
          do i=0,nx+1
             sp(i,j)=p(i,j)*thet(i,j)
             spt(i,j)=pt(i,j)*thet(i,j)
          enddo
       enddo
    case(1) !St Venant model, small slopes
       p(:,:)=0.
       pt(:,:)=0.
       thet(:,:)=1.
       ota(:,:)=1.
       sp(:,:)=0.
       spt(:,:)=0.
    end select model_type
    
  end subroutine topography_gradient

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

  !Curvature tensor
  subroutine topography_curvature
    Hxx(1:nx,1:ny)=(p(2:nx+1,1:ny)-p(0:nx-1,1:ny))/2.0/delx
    Hxy(1:nx,1:ny)=(pt(2:nx+1,1:ny)-pt(0:nx-1,1:ny))/2.0/delx
    Hyy(1:nx,1:ny)=(pt(1:nx,2:ny+1)-pt(1:nx,0:ny-1))/2.0/dely
  end subroutine topography_curvature

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

  !Compute curvature
  function curv(theta,ux,uy,px,py,i0,j0,itype)

    implicit double precision (a-h,o-z)
    integer :: i0,j0,itype
    
    if ((icurv.eq.0).or.((ux.eq.0).and.(uy.eq.0))) then
       
       !Curvature is not taken into account, or flow velocity is null
       curv=0
       
    else
       
       !Curvature is taken into account
       !Topography hessien matrix
       index_selection:select case (itype)
       case(0)! in (i0,j0)
          !cxx=(p(i0+1,j0)-p(i0-1,j0))/2.0/delx
          cxx=Hxx(i0,j0)
          cyy=Hyy(i0,j0)
          cxy=Hxy(i0,j0)
          cyx=cxy
       case(1)! in (i0+1/2,j0)
          cxx=(p(i0+1,j0)-p(i0,j0))/delx
          cyx=(pt(i0+1,j0)-pt(i0,j0))/delx
          cxy=(p(i0,j0+1)-p(i0,j0-1)+p(i0+1,j0+1)-p(i0+1,j0-1))/4.0/dely
          cyy=(pt(i0,j0+1)-pt(i0,j0-1)+pt(i0+1,j0+1)-pt(i0+1,j0-1))/4.0/dely
       case(2)! in (u0,j0+1/2)
          cxx=(p(i0+1,j0)-p(i0-1,j0)+p(i0+1,j0+1)-p(i0-1,j0+1))/4.0/delx
          cyx=(pt(i0+1,j0)-pt(i0-1,j0)+pt(i0+1,j0+1)-pt(i0-1,j0+1))/4.0/delx
          cxy=(p(i0,j0+1)-p(i0,j0))/dely
          cyy=(pt(i0,j0+1)-pt(i0,j0))/dely
       end select index_selection

       if (icurv==1) then
          !Use full curvature tensor
          curv=(ux*(cxx*ux+cyx*uy)+ &
               & uy*(cxy*ux+cyy*uy))
          curv=curv*theta**3
       else
          tmp=ux**2+uy**2
          !Topography curvature along x and y axes
          if ((icurv==2).or.(icurv==3)) then
             cxx=cxx/(sqrt(1+px**2))**3
             cyy=cyy/(sqrt(1+py**2))**3
          elseif ((icurv==21).or.(icurv==31)) then
             cxx=cxx*theta**3
             cyy=cyy*theta**3
          endif
          !Physical velocity
          unorm=theta*sqrt(ux**2+uy**2+(ux*px+uy*py)**2)
          !Threshold value for horizontal velocity component
          if (tmp.lt.10E-10) then
             !Use pseudo-mean curvature
             curv=unorm**2*0.5*(cxx+cyy)
          else
             if ((icurv==2).or.(icurv==21)) then
                !Projection on X and Y curvatures (cf VOLCFLOW)
                !Cosinus and sinus of angle between horizontal velocity and x-axis
                ca=abs(ux)/sqrt(tmp)
                sa=abs(uy)/sqrt(tmp)
                curv=unorm**2*(ca*cxx+sa*cyy)
             elseif ((icurv==3).or.(icurv==31)) then
                !Ponderation of x and y curvatures
                wx=ux**2/tmp
                wy=uy**2/tmp
                curv=unorm**2*(wx*cxx+wy*cyy)
             endif
          endif
       end if
       
    end if
    
  end function curv

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

  end module topography
