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

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

  !-------------------------------------------------
  
  !Apparent topography at the center of the cell
  subroutine apparent_topography_ij

    if (mordre.eq.1) then
       do j=1,ny
          do i=1,nx
             delbc(i,j)=0.d0
             delbcy(i,j)=0.d0
          enddo
       enddo
    else ! ordre 2
       do j=1,ny
          do i=1,nx
             thetloc=thet(i,j)

             curvature=curv(thetloc,u(i,j),ut(i,j),p(i,j),pt(i,j),i,j,0)

             fricloc=fric(rho(i,j),sqrt((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))&
                  & ,curvature/grav &
                  & ,thetloc,filt(i,j))

             if (fricloc.le.0.d0) then
                delbc(i,j)=0.d0
                delbcy(i,j)=0.d0
             else
                if (rhog(i,j)+rhod(i,j)+rhos(i,j)+rhon(i,j).gt.0.d0) then
                   ufric=(qgsave(i,j)+qdsave(i,j)+qssave(i,j)+qnsave(i,j))&
                        & /(rhog(i,j)+rhod(i,j)+rhos(i,j)+rhon(i,j))
                   utfric=(qtgsave(i,j)+qtdsave(i,j)+qtssave(i,j)+qtnsave(i,j))&
                        & /(rhog(i,j)+rhod(i,j)+rhos(i,j)+rhon(i,j))
                else
                   ufric=0.d0
                   utfric=0.d0
                endif
                ph=p(i,j)
                pth=pt(i,j)
                call projnum(ph,pth,fricloc,&
                     & 1./delx&
                     & *(rhog(i,j)*otag(i,j)&
                     & -rhod(i,j)*otad(i,j))-delzc(i,j)/delx&
                     & ,1./dely&
                     & *(rhos(i,j)*otas(i,j)&
                     & -rhon(i,j)*otan(i,j))-delzcy(i,j)/dely&
                     & ,1.d0/float(mordre)/delt/thetloc/grav*ufric&
                     & ,1.d0/float(mordre)/delt/thetloc/grav*utfric,proj,projt)
                delbc(i,j)=proj*delx
                delbcy(i,j)=projt*dely
             endif
          enddo
       enddo
       do j=1,ny
          delbc(0,j)=delbc(1,j)
          delbc(nx+1,j)=delbc(nx,j)
          delbcy(0,j)=delbcy(1,j)
          delbcy(nx+1,j)=delbcy(nx,j)
       enddo
       do i=1,nx
          delbc(i,0)=delbc(i,1)
          delbc(i,ny+1)=delbc(i,ny)
          delbcy(i,0)=delbcy(i,1)
          delbcy(i,ny+1)=delbcy(i,ny)
       enddo
    endif

  end subroutine apparent_topography_ij

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

  subroutine apparent_topography_i05j

    do j=1,ny
       do i=0,nx
          uh=.5d0*(ud(i,j)+ug(i+1,j))
          uth=.5d0*(utd(i,j)+utg(i+1,j))
          ph=.5d0*(pd(i,j)+pg(i+1,j))
          pth=.5d0*(ptd(i,j)+ptg(i+1,j))
          thetloc=1.d0/(.5d0/thetd(i,j)+.5d0/thetg(i+1,j))

          curvature=curv(thetloc,uh,uth,ph,pth,i,j,1)

          !cTest vdelta Antoine oct. 2007
          fricloc=fric(.5d0*(rhod(i,j)+rhog(i+1,j))&
               & ,sqrt((uh**2+uth**2+(ph*uh+pth*uth)**2)/(1.d0+ph**2+pth**2))&
               & ,curvature/grav &
               & ,thetloc,filt(i,j))

          delbclnorm=sqrt((1.d0+ph**2+pth**2)*((delbc(i,j)/delx)**2&
               & +(delbcy(i,j)/dely)**2)&
               & -(ph*delbc(i,j)/delx+pth*delbcy(i,j)/dely)**2)
          delbcrnorm=sqrt((1.d0+ph**2+pth**2)*((delbc(i+1,j)/delx)**2&
               & +(delbcy(i+1,j)/dely)**2)&
               & -(ph*delbc(i+1,j)/delx+pth*delbcy(i+1,j)/dely)**2)
          clim=fricloc-.5d0*(delbclnorm+delbcrnorm)
          if (clim.le.0.d0) then
             delb(i,j)=0.
          else
             if (rhod(i,j)+rhog(i+1,j).gt.0.d0) then
                ufric=(qdsave(i,j)+qgsave(i+1,j))/(rhod(i,j)+rhog(i+1,j))
                utfric=(qtdsave(i,j)+qtgsave(i+1,j))/(rhod(i,j)+rhog(i+1,j))
             else
                ufric=0.d0
                utfric=0.d0
             endif
             call projnum(ph,pth,clim,&
                  & 1./delx&
                  & *(rhod(i,j)*otad(i,j)&
                  & -rhog(i+1,j)*otag(i+1,j))-delz(i,j)/delx&
                  & ,-(1.&
                  & *(rhos(i,j+1)*otas(i,j+1)&
                  & -rhon(i,j)*otan(i,j)&
                  & +rhos(i,j)*otas(i,j)&
                  & -rhon(i,j-1)*otan(i,j-1)&
                  & +rhos(i+1,j+1)*otas(i+1,j+1)&
                  & -rhon(i+1,j)*otan(i+1,j)&
                  & +rhos(i+1,j)*otas(i+1,j)&
                  & -rhon(i+1,j-1)*otan(i+1,j-1))&
                  & +zs(i,j+1)-zn(i,j)+zs(i,j)-zn(i,j-1)&
                  & +zs(i+1,j+1)-zn(i+1,j)+zs(i+1,j)-zn(i+1,j-1))/4./dely&
                  & ,1.d0/float(mordre)/delt/thetloc/grav*ufric&
                  & ,1.d0/float(mordre)/delt/thetloc/grav*utfric,proj,projt)
             delb(i,j)=proj*delx
          endif
       enddo
    enddo

  end subroutine apparent_topography_i05j

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

  subroutine apparent_topography_ij05

    do i=1,nx
       do j=0,ny
          uh=.5d0*(un(i,j)+us(i,j+1))
          uth=.5d0*(utn(i,j)+uts(i,j+1))
          ph=.5d0*(pn(i,j)+ps(i,j+1))
          pth=.5d0*(ptn(i,j)+pts(i,j+1))
          thetloc=1.d0/(.5d0/thetn(i,j)+.5d0/thets(i,j+1))

          curvature=curv(thetloc,uh,uth,ph,pth,i,j,2)

          fricloc=fric(.5d0*(rhon(i,j)+rhos(i,j+1))&
               & ,sqrt((uh**2+uth**2+(ph*uh+pth*uth)**2)/(1.d0+ph**2+pth**2))&
               & ,curvature/grav &
               & ,thetloc,filt(i,j))


          delbcsnorm=sqrt((1.d0+ph**2+pth**2)*((delbc(i,j)/delx)**2&
               & +(delbcy(i,j)/dely)**2)&
               & -(ph*delbc(i,j)/delx+pth*delbcy(i,j)/dely)**2)
          delbcnnorm=sqrt((1.d0+ph**2+pth**2)*((delbc(i,j+1)/delx)**2&
               & +(delbcy(i,j+1)/dely)**2)&
               & -(ph*delbc(i,j+1)/delx+pth*delbcy(i,j+1)/dely)**2)
          clim=fricloc-.5d0*(delbcsnorm+delbcnnorm)
          if (clim.le.0.d0) then
             delby(i,j)=0.d0
          else
             if (rhon(i,j)+rhos(i,j+1).gt.0.d0) then
                ufric=(qnsave(i,j)+qssave(i,j+1))/(rhon(i,j)+rhos(i,j+1))
                utfric=(qtnsave(i,j)+qtssave(i,j+1))/(rhon(i,j)+rhos(i,j+1))
             else
                ufric=0.d0
                utfric=0.d0
             endif
             call projnum(ph,pth,clim&
                  & ,-(1.&
                  & *(rhog(i+1,j)*otag(i+1,j)&
                  & -rhod(i,j)*otad(i,j)&
                  & +rhog(i,j)*otag(i,j)&
                  & -rhod(i-1,j)*otad(i-1,j)&
                  & +rhog(i+1,j+1)*otag(i+1,j+1)&
                  & -rhod(i,j+1)*otad(i,j+1)&
                  & +rhog(i,j+1)*otag(i,j+1)&
                  & -rhod(i-1,j+1)*otad(i-1,j+1))&
                  & +zg(i+1,j)-zd(i,j)+zg(i,j)-zd(i-1,j)&
                  & +zg(i+1,j+1)-zd(i,j+1)+zg(i,j+1)-zd(i-1,j+1))/4./delx&
                  & ,1./dely&
                  & *(rhon(i,j)*otan(i,j)&
                  & -rhos(i,j+1)*otas(i,j+1))-delzy(i,j)/dely&
                  & ,1.d0/float(mordre)/delt/thetloc/grav*ufric&
                  & ,1.d0/float(mordre)/delt/thetloc/grav*utfric,proj,projt)
             delby(i,j)=projt*dely
          endif
       enddo
    enddo

  end subroutine apparent_topography_ij05
  
  !-------------------------------------------------

  !Friction regularization
  
  !Old version with different projection method
  
!!$  subroutine projnum(ph,pth,clim,compens,compenst,arg,argt&
!!$       & ,proj,projt,b11,b12,b21,b22)
!!$    implicit double precision (a-h,o-z)
!!$    double precision,intent(in) :: ph,pth,clim,compens,compenst&
!!$         & ,arg,argt,b11,b12,b21,b22
!!$    double precision,intent(out) :: proj,projt
!!$    if (ieq.eq.1) then
!!$       bnorm=max(1.d0,b11+abs(b12),b22+abs(b21))
!!$       a11=1.d0-b11/bnorm
!!$       a12=-b12/bnorm
!!$       a21=-b21/bnorm
!!$       a22=1.d0-b22/bnorm
!!$       deta=max(1.d-28,a11*a22-a12*a21)
!!$       amt11=a22/deta
!!$       amt12=-a21/deta
!!$       amt21=-a12/deta
!!$       amt22=a11/deta
!!$    else
!!$       amt11=1.d0
!!$       amt12=0.d0
!!$       amt21=0.d0
!!$       amt22=1.d0
!!$    endif
!!$    proj1=compens
!!$    proj1t=compenst
!!$    proj1norm=sqrt((1.d0&
!!$         & +ph**2+pth**2)*((amt11*proj1+amt12*proj1t)**2&
!!$         & +(amt21*proj1+amt22*proj1t)**2)-(ph*(amt11*proj1+amt12*proj1t)&
!!$         & +pth*(amt21*proj1+amt22*proj1t))**2)
!!$    if (proj1norm.gt.clim) then
!!$       proj1=proj1/proj1norm*clim
!!$       proj1t=proj1t/proj1norm*clim
!!$    endif
!!$    arg1=(arg+ph*(ph*arg+pth*argt))/(1.d0+ph**2+pth**2)
!!$    arg1t=(argt+pth*(ph*arg+pth*argt))/(1.d0+ph**2+pth**2)
!!$    arg1norm=sqrt((1.d0+ph**2+pth**2)*((amt11*arg1+amt12*arg1t)**2&
!!$         & +(amt21*arg1+amt22*arg1t)**2)-(ph*(amt11*arg1+amt12*arg1t)&
!!$         & +pth*(amt21*arg1+amt22*arg1t))**2)
!!$    if (arg1norm.gt.0.d0) then
!!$       scal=2.d0/(1.d0+max(1.d0,-((1.d0+ph**2+pth**2)*(&
!!$            &  (amt11*arg1+amt12*arg1t)*(amt11*compens+amt12*compenst)&
!!$            &  +(amt21*arg1+amt22*arg1t)*(amt21*compens+amt22*compenst))&
!!$            &  -(ph*(amt11*arg1+amt12*arg1t)+pth*(amt21*arg1+amt22*arg1t))&
!!$            &  *(ph*(amt11*compens+amt12*compenst)&
!!$            &  +pth*(amt21*compens+amt22*compenst)))&
!!$            &  /arg1norm/clim))
!!$    else
!!$       scal=1.d0
!!$    endif
!!$    proj2=proj1+scal*arg1
!!$    proj2t=proj1t+scal*arg1t
!!$    proj2norm=sqrt((1.d0+ph**2+pth**2)*((amt11*proj2+amt12*proj2t)**2&
!!$         & +(amt21*proj2+amt22*proj2t)**2)-(ph*(amt11*proj2+amt12*proj2t)&
!!$         & +pth*(amt21*proj2+amt22*proj2t))**2)
!!$    if (proj2norm.gt.clim) then
!!$       proj2=proj2/proj2norm*clim
!!$       proj2t=proj2t/proj2norm*clim
!!$    endif
!!$    proj=proj2
!!$    projt=proj2t
!!$  end subroutine projnum

  subroutine projnum(ph,pth,clim,compens,compenst,arg,argt&
       & ,proj,projt)
    implicit double precision (a-h,o-z)
    double precision,intent(in) :: ph,pth,clim,compens,compenst&
         & ,arg,argt
    double precision,intent(out) :: proj,projt
    proj1=compens
    proj1t=compenst
    proj1norm=sqrt((1.d0+ph**2+pth**2)*(proj1**2+proj1t**2)-&
         (ph*proj1+pth*proj1t)**2)
    if (proj1norm.gt.clim) then
       proj1=proj1/proj1norm*clim
       proj1t=proj1t/proj1norm*clim
    endif
    arg1=(arg+ph*(ph*arg+pth*argt))/(1.d0+ph**2+pth**2)
    arg1t=(argt+pth*(ph*arg+pth*argt))/(1.d0+ph**2+pth**2)
    arg1norm=sqrt((1.d0+ph**2+pth**2)*(arg1**2+arg1t**2)&
         -(ph*arg1+pth*arg1t)**2)
    if (arg1norm.gt.0.d0) then
       scal=2.d0/(1.d0+max(1.d0,-((1.d0+ph**2+pth**2)*&
            &  (arg1*compens +arg1t*compenst)&
            &  -(ph*arg1+pth*arg1t)*(ph*compens+pth*compenst))&
            &  /arg1norm/clim))
    else
       scal=1.d0
    endif
    proj2=proj1+scal*arg1
    proj2t=proj1t+scal*arg1t
    proj2norm=sqrt((1.d0+ph**2+pth**2)*(proj2**2+proj2t**2)-&
         (ph*proj2+pth*proj2t)**2)
    if (proj2norm.gt.clim) then
       proj2=proj2/proj2norm*clim
       proj2t=proj2t/proj2norm*clim
    endif
    proj=proj2
    projt=proj2t
  end subroutine projnum

end module apparent_topography
