source: LMDZ5/trunk/libf/dyn3dmem/exner_milieu_loc.F @ 1663

!
! $Id $
!
      SUBROUTINE  exner_milieu_loc ( ngrid, ps, p,beta, pks, pk, pkf )
c
c     Auteurs :  F. Forget , Y. Wanherdrick
c P.Le Van  , Fr. Hourdin  .
c    ..........
c
c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
c    .... beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
c
c   ************************************************************************
c    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
c   ************************************************************************
c    .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
c    la pression et la fonction d'Exner  au  sol  .
c
c     WARNING : CECI est une version speciale de exner_hyb originale
c               Utilise dans la version martienne pour pouvoir 
c               tourner avec des coordonnees verticales complexe
c              => Il ne verifie PAS la condition la proportionalite en 
c              energie totale/ interne / potentielle (F.Forget 2001)
c    ( voir note de Fr.Hourdin )  ,
c
      USE parallel
      IMPLICIT NONE
c
#include "dimensions.h"
#include "paramet.h"
#include "comconst.h"
#include "comgeom.h"
#include "comvert.h"
#include "serre.h"

      INTEGER  ngrid
      REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
      REAL pkf(ijb_u:ije_u,llm)
      REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
      REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm)

c    .... variables locales   ...

      INTEGER l, ij
      REAL dum1

      REAL ppn(iim),pps(iim)
      REAL xpn, xps
      REAL SSUM
      EXTERNAL SSUM
      INTEGER ije,ijb,jje,jjb
      logical,save :: firstcall=.true.
!$OMP THREADPRIVATE(firstcall) 
      character(len=*),parameter :: modname="exner_milieu_p"

      ! Sanity check
      if (firstcall) then
        ! check that vertical discretization is compatible
        ! with this routine
        if (disvert_type.ne.2) then
          call abort_gcm(modname,
     &     "this routine should only be called if disvert_type==2",42)
        endif
        
        ! sanity checks for Shallow Water case (1 vertical layer)
        if (llm.eq.1) then
          if (kappa.ne.1) then
            call abort_gcm(modname,
     &      "kappa!=1 , but running in Shallow Water mode!!",42)
          endif
          if (cpp.ne.r) then
            call abort_gcm(modname,
     &      "cpp!=r , but running in Shallow Water mode!!",42)
          endif
        endif ! of if (llm.eq.1)

        firstcall=.false.
      endif ! of if (firstcall)
      
c$OMP BARRIER

! Specific behaviour for Shallow Water (1 vertical layer) case
      if (llm.eq.1) then
              
        ! Compute pks(:),pk(:),pkf(:)
        ijb=ij_begin
        ije=ij_end
!$OMP DO SCHEDULE(STATIC)
        DO ij=ijb, ije
          pks(ij)=(cpp/preff)*ps(ij)
          pk(ij,1) = .5*pks(ij)
          pkf(ij,1)=pk(ij,1)
        ENDDO
!$OMP ENDDO

!$OMP MASTER
      if (pole_nord) then
        DO  ij   = 1, iim
          ppn(ij) = aire(   ij   ) * pks(  ij     )
        ENDDO
        xpn      = SSUM(iim,ppn,1) /apoln
  
        DO ij   = 1, iip1
          pks(   ij     )  =  xpn
          pk(ij,1) = .5*pks(ij)
          pkf(ij,1)=pk(ij,1)
        ENDDO
      endif
      
      if (pole_sud) then
        DO  ij   = 1, iim
          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
        ENDDO
        xps      = SSUM(iim,pps,1) /apols 
  
        DO ij   = 1, iip1
          pks( ij+ip1jm )  =  xps
          pk(ij+ip1jm,1)=.5*pks(ij+ip1jm)
          pkf(ij+ip1jm,1)=pk(ij+ip1jm,1)
        ENDDO
      endif
!$OMP END MASTER

        jjb=jj_begin
        jje=jj_end
        CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )

        ! our work is done, exit routine
        return
      endif ! of if (llm.eq.1)

!!!! General case:

c     -------------
c     Calcul de pks
c     -------------
   
      ijb=ij_begin
      ije=ij_end

c$OMP DO SCHEDULE(STATIC)
      DO   ij  = ijb, ije
        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
      ENDDO
c$OMP ENDDO
c Synchro OPENMP ici

c$OMP MASTER
      if (pole_nord) then
        DO  ij   = 1, iim
          ppn(ij) = aire(   ij   ) * pks(  ij     )
        ENDDO
        xpn      = SSUM(iim,ppn,1) /apoln
  
        DO ij   = 1, iip1
          pks(   ij     )  =  xpn
        ENDDO
      endif
      
      if (pole_sud) then
        DO  ij   = 1, iim
          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
        ENDDO
        xps      = SSUM(iim,pps,1) /apols 
  
        DO ij   = 1, iip1
          pks( ij+ip1jm )  =  xps
        ENDDO
      endif
c$OMP END MASTER
c
c
c    .... Calcul de pk  pour la couche l 
c    --------------------------------------------
c
      dum1 = cpp * (2*preff)**(-kappa) 
      DO l = 1, llm-1
c$OMP DO SCHEDULE(STATIC)
        DO   ij   = ijb, ije
         pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
        ENDDO
c$OMP ENDDO NOWAIT        
      ENDDO

c    .... Calcul de pk  pour la couche l = llm ..
c    (on met la meme distance (en log pression)  entre Pk(llm)
c    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)

c$OMP DO SCHEDULE(STATIC)
      DO   ij   = ijb, ije
         pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
      ENDDO
c$OMP ENDDO NOWAIT        


c    calcul de pkf
c    -------------
c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
      DO l = 1, llm
c$OMP DO SCHEDULE(STATIC)
         DO   ij   = ijb, ije
           pkf(ij,l)=pk(ij,l)
         ENDDO
c$OMP ENDDO NOWAIT             
      ENDDO

c$OMP BARRIER
      
      jjb=jj_begin
      jje=jj_end
      CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
      
c    EST-CE UTILE ?? : calcul de beta
c    --------------------------------
      DO l = 2, llm
c$OMP DO SCHEDULE(STATIC)
        DO   ij   = ijb, ije
          beta(ij,l) = pk(ij,l) / pk(ij,l-1)   
        ENDDO
c$OMP ENDDO NOWAIT             
      ENDDO

      RETURN
      END