! $Id: disvert.F90 1520 2011-05-23 11:37:09Z emillour $

SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,scaleheight)

  ! Auteur : P. Le Van

  IMPLICIT NONE

  include "dimensions.h"
  include "paramet.h"
  include "iniprint.h"
  include "logic.h"

  ! s = sigma ** kappa : coordonnee verticale
  ! dsig(l) : epaisseur de la couche l ds la coord. s
  ! sig(l) : sigma a l'interface des couches l et l-1
  ! ds(l) : distance entre les couches l et l-1 en coord.s

  real,intent(in) :: pa, preff
  real,intent(out) :: ap(llmp1), bp(llmp1)
  real,intent(out) :: dpres(llm), nivsigs(llm), nivsig(llmp1)
  real,intent(out) :: presnivs(llm)
  real,intent(out) :: scaleheight

  REAL sig(llm+1), dsig(llm)
  real zk, zkm1, dzk1, dzk2, k0, k1

  INTEGER l
  REAL dsigmin
  REAL alpha, beta, deltaz,scaleheight
  INTEGER iostat
  REAL x
  character(len=*),parameter :: modname="disvert"

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

  ! default scaleheight is 8km for earth
  scaleheight=8.

  OPEN(99, file='sigma.def', status='old', form='formatted', iostat=iostat)

  IF (iostat == 0) THEN
     ! cas 1 on lit les options dans sigma.def:
     READ(99, *) scaleheight ! hauteur d'echelle 8.
     READ(99, *) deltaz ! epaiseur de la premiere couche 0.04
     READ(99, *) beta ! facteur d'acroissement en haut 1.3
     READ(99, *) k0 ! nombre de couches dans la transition surf
     READ(99, *) k1 ! nombre de couches dans la transition haute
     CLOSE(99)
     alpha=deltaz/(llm*scaleheight)
     write(lunout, *)trim(modname),':scaleheight, alpha, k0, k1, beta', &
                               scaleheight, alpha, k0, k1, beta

     alpha=deltaz/tanh(1./k0)*2.
     zkm1=0.
     sig(1)=1.
     do l=1, llm
        sig(l+1)=(cosh(l/k0))**(-alpha*k0/scaleheight) &
             *exp(-alpha/scaleheight*tanh((llm-k1)/k0) &
                  *beta**(l-(llm-k1))/log(beta))
        zk=-scaleheight*log(sig(l+1))

        dzk1=alpha*tanh(l/k0)
        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
        write(lunout, *)l, sig(l+1), zk, zk-zkm1, dzk1, dzk2
        zkm1=zk
     enddo

     sig(llm+1)=0.

     DO l = 1, llm
        dsig(l) = sig(l)-sig(l+1)
     end DO
  ELSE
     if (ok_strato) then
        if (llm==39) then
           dsigmin=0.3
        else if (llm==50) then
           dsigmin=1.
        else
           write(lunout,*) trim(modname), &
           ' ATTENTION discretisation z a ajuster'
           dsigmin=1.
        endif
        write(lunout,*) trim(modname), &
        ' Discretisation verticale DSIGMIN=',dsigmin
     endif

     DO l = 1, llm
        x = 2*asin(1.) * (l - 0.5) / (llm + 1)

        IF (ok_strato) THEN
           dsig(l) =(dsigmin + 7. * SIN(x)**2) &
                *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
        ELSE
           dsig(l) = 1.0 + 7.0 * SIN(x)**2
        ENDIF
     ENDDO
     dsig = dsig / sum(dsig)
     sig(llm+1) = 0.
     DO l = llm, 1, -1
        sig(l) = sig(l+1) + dsig(l)
     ENDDO
  ENDIF

  DO l=1, llm
     nivsigs(l) = REAL(l)
  ENDDO

  DO l=1, llmp1
     nivsig(l)= REAL(l)
  ENDDO

  ! .... Calculs de ap(l) et de bp(l) ....
  ! ..... pa et preff sont lus sur les fichiers start par lectba .....

  bp(llmp1) = 0.

  DO l = 1, llm
     bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
     ap(l) = pa * ( sig(l) - bp(l) )
  ENDDO

  bp(1)=1.
  ap(1)=0.

  ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )

  write(lunout, *)  trim(modname),': BP '
  write(lunout, *) bp
  write(lunout, *)  trim(modname),': AP '
  write(lunout, *) ap

  write(lunout, *) 'Niveaux de pressions approximatifs aux centres des'
  write(lunout, *)'couches calcules pour une pression de surface =', preff
  write(lunout, *) 'et altitudes equivalentes pour une hauteur d echelle de '
  write(lunout, *) scaleheight,' km'
  DO l = 1, llm
     dpres(l) = bp(l) - bp(l+1)
     presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
     write(lunout, *)'PRESNIVS(', l, ')=', presnivs(l), ' Z ~ ', &
          log(preff/presnivs(l))*scaleheight &
          , ' DZ ~ ', scaleheight*log((ap(l)+bp(l)*preff)/ &
          max(ap(l+1)+bp(l+1)*preff, 1.e-10))
  ENDDO

  write(lunout, *) trim(modname),': PRESNIVS '
  write(lunout, *) presnivs

END SUBROUTINE disvert