sutoph.F90

Go to the documentation of this file.

!OPTIONS XOPT(NOEVAL)
SUBROUTINE sutoph(KULOUT)

!**** *SUTOPH*   - Initialize common YOMTOPH top parameterization

!     Purpose.
!     --------
!           Initialize YOMTOPH, the common that contains the top pressure
!           and the first level of parameterization
!           it also contains mesospheric drag vertical profil

!**   Interface.
!     ----------
!        *CALL* *SUTOPH(KULOUT)

!        Explicit arguments :
!        --------------------
!        KULOUT : Logical unit for the output

!        Implicit arguments :
!        --------------------
!        COMMON YOMTOPH, YOMSTA

!     Method.
!     -------
!        See documentation

!     Externals.
!     ----------

!     Reference.
!     ----------
!        Documentation ARPEGE

!     Author.
!     -------
!        A. Lasserre-Bigorry

!     Modifications.
!     --------------
!        Original : 91-06-10
!        Modified 92-02-22 by M. Deque (test of consistency between phys. para.)
!        Modified by R. EL Khatib : 93-04-02 Set-up defaults controled by LECMWF
!        Modified 93-11-17 by Ph. Dandin : FMR scheme with MF physics
!        Modified 97-05-17 by M. Deque   : frozen FMR                 
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        F.Bouyssel 04-11-22 : NTCOET,ETCOET
!        P. Marquet 05-09-12 : NTAJUC
!        M. Deque   05-09-12 : default RCLX
!        M. Deque   05-09-12 : default TPSCLIM
!     ------------------------------------------------------------------

USE parkind1  ,ONLY : jpim     ,jprb
USE yomhook   ,ONLY : lhook,   dr_hook

USE yomdim   , ONLY : nflevg
! Ce qui concerne NULNAM commente par MPL le 15.04.09
!USE YOMLUN   , ONLY : NULNAM
USE yomct0b  , ONLY : lecmwf
USE yomsta   , ONLY : stpre
USE yomtoph  , ONLY : rmesou   ,rmesot   ,ntqsat   ,ntdifu   ,&
 & ntcoef   ,ntdrag   ,ntcvim   ,ntplui   ,ntradi   ,&
 & ntnebu   ,ntozon   ,ntdrme   ,etqsat   ,etdifu   ,&
 & etcoef   ,etdrag   ,etcvim   ,etplui   ,etradi   ,&
 & etnebu   ,etozon   ,etdrme   ,xdrmuk   ,xdrmux   ,xdrmup   ,&
 & xdrmtk   ,xdrmtx   ,xdrmtp   ,ntcoet   ,etcoet   ,&
 & rmesoq   ,xdrmqk   ,xdrmqp   ,rfmesoq  ,rclx     ,&
 & ntajuc   ,etajuc   ,tpsclim
USE yomphy   , ONLY : lray     ,lrayfm   ,lrayfm15 ,lrrmes
USE yoephy   , ONLY : lagphy

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KULOUT 

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

INTEGER(KIND=JPIM) :: JLEV

REAL(KIND=JPRB) :: PAP, PAPX, ZMEST, ZMESU, ZMESQ

REAL(KIND=JPRB) :: PMESQF
REAL(KIND=JPRB) :: PMESTF
REAL(KIND=JPRB) :: PMESUF
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "namtoph.h"

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

!*    Mesospheric drag shape function

!     PMESUF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP**1.5,1.E-10),0. )
pmesuf(pap,papx) = max( (papx-pap)/max(pap,1.e-10_jprb),0.0_jprb )
pmestf(pap,papx) = max( (papx-pap)/max(pap,1.e-10_jprb),0.0_jprb )
pmesqf(pap,papx) = max( (papx-pap)/max(pap,1.e-10_jprb),0.0_jprb )

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

#include "abor1.intfb.h"
#include "posnam.intfb.h"
#include "seapre.intfb.h"

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

IF (lhook) CALL dr_hook('SUTOPH',0,zhook_handle)

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

!*       1.    Set default values.
!              -------------------

!        1.1 Set implicit default values

etqsat=0._jprb
etdifu=0._jprb
etcoef=0._jprb
etdrag=0._jprb
etcvim=0._jprb
etplui=0._jprb
etradi=0._jprb
etnebu=0._jprb
etozon=0._jprb
etdrme=0._jprb
etcoet=0._jprb
etajuc=0._jprb
ntqsat=1
ntdifu=1
ntcoef=1
ntdrag=1
ntcvim=1
ntplui=1
ntradi=1
ntnebu=1
ntozon=1
ntdrme=1
ntcoet=1
ntajuc=1

xdrmuk=0._jprb
xdrmux=0._jprb
xdrmup=0._jprb
xdrmtk=0._jprb
xdrmtx=0._jprb
xdrmtp=0._jprb
xdrmqk=0._jprb
xdrmqp=0._jprb

rfmesoq=3.725e-06_jprb
rclx=0.0_jprb
tpsclim=197._jprb

!        1.2 Modify default values according to LECMWF

IF (lecmwf) THEN
ELSE
ENDIF

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

!*       2.    Modify default values.
!              ----------------------

! Ce qui concerne NAMTOPH commente par MPL le 15.04.09
!CALL POSNAM(NULNAM,'NAMTOPH')
!READ(NULNAM,NAMTOPH)

!*       2.1  Search corresponding level, to pressure in NAMTOPH
!             for each parameterization

IF(etqsat /= 0.0_jprb) CALL seapre (etqsat,ntqsat,stpre,nflevg)
IF(etdifu /= 0.0_jprb) CALL seapre (etdifu,ntdifu,stpre,nflevg)
IF(etcoef /= 0.0_jprb) CALL seapre (etcoef,ntcoef,stpre,nflevg)
IF(etdrag /= 0.0_jprb) CALL seapre (etdrag,ntdrag,stpre,nflevg)
IF(etcvim /= 0.0_jprb) CALL seapre (etcvim,ntcvim,stpre,nflevg)
IF(etplui /= 0.0_jprb) CALL seapre (etplui,ntplui,stpre,nflevg)
IF(etradi /= 0.0_jprb) THEN
  IF (lray) THEN
    CALL seapre (etradi,ntradi,stpre,nflevg)
  ENDIF
  IF (lrayfm.OR.lrayfm15) THEN
    etradi=0._jprb
    ntradi=1
  ENDIF
ENDIF
IF(etnebu /= 0.0_jprb) CALL seapre (etnebu,ntnebu,stpre,nflevg)
IF(etozon /= 0.0_jprb) CALL seapre (etozon,ntozon,stpre,nflevg)
IF(etdrme /= 0.0_jprb) CALL seapre (etdrme,ntdrme,stpre,nflevg)
IF(etcoet /= 0.0_jprb) CALL seapre (etcoet,ntcoet,stpre,nflevg)
IF(etajuc /= 0.0_jprb) CALL seapre (etajuc,ntajuc,stpre,nflevg)
!     ------------------------------------------------------------------

!*       3.    Print final values.
!              -------------------

WRITE(unit=kulout,fmt='('' COMMON YOMTOPH '')')
WRITE(unit=kulout,fmt='('' ETQSAT = '',E10.4,'' NTQSAT = '',I10 &
 & ,'' ETDIFU = '',E10.4,'' NTDIFU = '',I10 &
 & ,/,'' ETCOEF = '',E10.4,'' NTCOEF = '',I10 &
 & ,'' ETDRAG = '',E10.4,'' NTDRAG = '',I10 &
 & ,/,'' ETCVIM = '',E10.4,'' NTCVIM = '',I10 &
 & ,'' ETPLUI = '',E10.4,'' NTPLUI = '',I10 &
 & ,/,'' ETRADI = '',E10.4,'' NTRADI = '',I10 &
 & ,'' ETNEBU = '',E10.4,'' NTNEBU = '',I10 &
 & ,/,'' ETOZON = '',E10.4,'' NTOZON = '',I10 &
 & ,'' ETDRME = '',E10.4,'' NTDRME = '',I10 &
 & ,/,'' ETCOET = '',E10.4,'' NTCOET = '',I10 &
 & ,/,'' ETAJUC = '',E10.4,'' NTAJUC = '',I10 &
 & ,/,'' XDRMUK = '',E10.4,'' XDRMUP = '',E10.4 &
 & ,'' XDRMUX = '',E10.4,'' XDRMTK = '',E10.4 &
 & ,'' XDRMTP = '',E10.4,'' XDRMTX = '',E10.4 &
 & ,'' XDRMQK = '',E11.4,'' XDRMQP = '',E11.4 &
 & ,/,'' RFMESOQ= '',E11.4,'' RCLX   = '',E11.4 &
 & )')&
 & etqsat,ntqsat,etdifu,ntdifu &
 & ,etcoef,ntcoef,etdrag,ntdrag &
 & ,etcvim,ntcvim,etplui,ntplui &
 & ,etradi,ntradi,etnebu,ntnebu &
 & ,etozon,ntozon,etdrme,ntdrme &
 & ,etcoet,ntcoet &
 & ,etajuc,ntajuc &
 & ,xdrmuk,xdrmup,xdrmux,xdrmtk,xdrmtp,xdrmtx &
 & ,xdrmqk,xdrmqp,rfmesoq,rclx

!     VERIFICATION OF CONSISTENCY BETWEEN PHYSICAL PARAMETERIZATION

IF (etcoef > etdifu.OR.etcoef > etdrag)THEN
  WRITE(unit=kulout,fmt='('' ETCOEF TOO LOW '')')
  CALL abor1('SUTOPH')
ENDIF
IF (etqsat > etnebu.OR.etqsat > etplui.OR.etqsat > etcvim)THEN
  WRITE(unit=kulout,fmt='('' ETQSAT TOO LOW '')')
  CALL abor1('SUTOPH')
ENDIF
IF (etcvim > etnebu)THEN
  WRITE(unit=kulout,fmt='('' ETCVIM TOO LOW '')')
  CALL abor1('SUTOPH')
ENDIF

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

!*       4.    INITIALIZE MESOSPHERIC DRAG FOR U,V AND T
!              -----------------------------------------

IF (lrrmes.AND..NOT.lagphy) THEN
  WRITE (unit=kulout,fmt='('' PROFIL VERTICAL DE DRAG MESO'',/&
   & ,'' LEV'',T15,''VITESSE'',T45,''TEMPERATURE'' &
   & , T65, ''HUMIDITE'' )')  
  DO jlev=1,nflevg
    rmesou(jlev)=xdrmuk*pmesuf(stpre(jlev),xdrmup)
    rmesot(jlev)=xdrmtk*pmestf(stpre(jlev),xdrmtp)
    rmesoq(jlev)=xdrmqk*pmesqf(stpre(jlev),xdrmqp)
    IF (xdrmux /= 0.0_jprb) rmesou(jlev)=min(rmesou(jlev),xdrmux)
    IF (xdrmtx /= 0.0_jprb) rmesot(jlev)=min(rmesot(jlev),xdrmtx)
    zmesu=1.0_jprb/max(1.e-8_jprb,rmesou(jlev)*3600._jprb*24._jprb)
    zmest=1.0_jprb/max(1.e-8_jprb,rmesot(jlev)*3600._jprb*24._jprb)
    zmesq=1.0_jprb/max(1.e-8_jprb,rmesoq(jlev)*3600._jprb*24._jprb)
    WRITE (unit=kulout,fmt='(I3,T10,E9.3,T20,G9.3,T40,E9.3,T50 &
     & ,G9.3, T70,E9.3, T80,G9.3)') jlev,rmesou(jlev),zmesu, &
     & rmesot(jlev),zmest, &
     & rmesoq(jlev),zmesq 
  ENDDO
ENDIF

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

IF (lhook) CALL dr_hook('SUTOPH',1,zhook_handle)
END SUBROUTINE sutoph