limx.f90 Source File

!
! $Header$
!
SUBROUTINE limx(s0,sx,sm,pente_max)
  !
  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
  !
  !    ********************************************************************
  ! Shema  d'advection " pseudo amont " .
  !    ********************************************************************
  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
  !
  !
  !   --------------------------------------------------------------------
  USE comgeom_mod_h
  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
USE paramet_mod_h
IMPLICIT NONE
  !


  !
  !
  !   Arguments:
  !   ----------
  real :: pente_max
  REAL :: s0(ip1jmp1,llm),sm(ip1jmp1,llm)
  real :: sx(ip1jmp1,llm)
  !
  !  Local
  !   ---------
  !
  INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
  integer :: n0,iadvplus(ip1jmp1,llm),nl(llm)
  !
  REAL :: q(ip1jmp1,llm)
  real :: dxq(ip1jmp1,llm)


  REAL :: new_m,zm
  real :: dxqu(ip1jmp1)
  real :: adxqu(ip1jmp1),dxqmax(ip1jmp1)

  Logical :: extremum,first
  save first

  REAL :: SSUM,CVMGP,CVMGT
  integer :: ismax,ismin
  EXTERNAL  SSUM, ismin,ismax

  data first/.true./


   DO  l = 1,llm
     DO  ij=1,ip1jmp1
           q(ij,l) = s0(ij,l) / sm ( ij,l )
           dxq(ij,l) = sx(ij,l) /sm(ij,l)
     ENDDO
   ENDDO

  !   calcul de la pente a droite et a gauche de la maille

  do l = 1, llm
     do ij=iip2,ip1jm-1
        dxqu(ij)=q(ij+1,l)-q(ij,l)
     enddo
     do ij=iip1+iip1,ip1jm,iip1
        dxqu(ij)=dxqu(ij-iim)
     enddo

     do ij=iip2,ip1jm
        adxqu(ij)=abs(dxqu(ij))
     enddo

  !   calcul de la pente maximum dans la maille en valeur absolue

     do ij=iip2+1,ip1jm
        dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))
     enddo

     do ij=iip1+iip1,ip1jm,iip1
        dxqmax(ij-iim)=dxqmax(ij)
     enddo

  !   calcul de la pente avec limitation

     do ij=iip2+1,ip1jm
        if(     dxqu(ij-1)*dxqu(ij).gt.0. &
              .and. dxq(ij,l)*dxqu(ij).gt.0.) then
          dxq(ij,l)= &
                sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))
        else
  !   extremum local
           dxq(ij,l)=0.
        endif
     enddo
     do ij=iip1+iip1,ip1jm,iip1
        dxq(ij-iim,l)=dxq(ij,l)
     enddo

     DO  ij=1,ip1jmp1
           sx(ij,l) = dxq(ij,l)*sm(ij,l)
     ENDDO

   ENDDO

  RETURN
END SUBROUTINE limx