source: trunk/LMDZ.COMMON/libf/dyn3d_common/exner_hyb.F @ 1300

!
! $Id $
!
      SUBROUTINE  exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
c
c     Auteurs :  P.Le Van  , Fr. Hourdin  .
c    ..........
c
c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
c
c   ************************************************************************
c    Calcule la fonction d'Exner pk = Cp * p ** 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                                 -------- z                                   
c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
c    ( voir note de Fr.Hourdin )  ,
c
c    on determine successivement , du haut vers le bas des couches, les 
c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
c
c
      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(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
      REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)

c    .... variables locales   ...

      INTEGER l, ij
      REAL unpl2k,dellta

      REAL ppn(iim),pps(iim)
      REAL xpn, xps
      REAL SSUM
c
      logical,save :: firstcall=.true.
      character(len=*),parameter :: modname="exner_hyb"
      
      ! Sanity check
      if (firstcall) then
        ! 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)

      if (llm.eq.1) then
        
        ! Compute pks(:),pk(:),pkf(:)
        
        DO   ij  = 1, ngrid
          pks(ij) = (cpp/preff) * ps(ij) 
          pk(ij,1) = .5*pks(ij)
        ENDDO
        
        CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
        CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 
        
        ! our work is done, exit routine
        return

      endif ! of if (llm.eq.1)

!!!! General case:
     
      unpl2k    = 1.+ 2.* kappa
c
      DO   ij  = 1, ngrid
        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
      ENDDO

      DO  ij   = 1, iim
        ppn(ij) = aire(   ij   ) * pks(  ij     )
        pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
      ENDDO
      xpn      = SSUM(iim,ppn,1) /apoln
      xps      = SSUM(iim,pps,1) /apols

      DO ij   = 1, iip1
        pks(   ij     )  =  xpn
        pks( ij+ip1jm )  =  xps
      ENDDO
c
c
c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
c
      DO     ij      = 1, ngrid
       alpha(ij,llm) = 0.
       beta (ij,llm) = 1./ unpl2k
      ENDDO
c
c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
c
      DO l = llm -1 , 2 , -1
c
        DO ij = 1, ngrid
        dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
        alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
        beta (ij,l)  =   p(ij,l  ) / dellta   
        ENDDO
c
      ENDDO
c
c  ***********************************************************************
c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
c
      DO   ij   = 1, ngrid
       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
      ENDDO
c
c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
c
      DO l = 2, llm
        DO   ij   = 1, ngrid
         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
        ENDDO
      ENDDO
c
c
      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
      CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
      

      RETURN
      END