suphec.F90

Go to the documentation of this file.

SUBROUTINE suphec(KULOUT)

!**** *SUPHEC - INITIALISES PHYSICAL CONSTANTS OF UNCERTAIN VALUE.
!               WITHIN THE E.C.M.W.F. PHYSICS PACKAGE

!     PURPOSE.
!     --------

!          THIS ROUTINE SETS THE VALUES FOR THE PHYSICAL CONSTANTS USED
!     IN THE PARAMETERIZATION ROUTINES WHENEVER THESE VALUES ARE NOT
!     KNOWN WELL ENOUGH TO FORBID ANY TUNING OR WHENEVER THEY ARE
!     SUBJECT TO AN ARBITRARY CHOICE OF THE MODELLER. THESE CONSTANTS
!     ARE DISTRIBUTED IN COMMON DECKS *YOEXXXX* WHERE XXXX CORRESPONDS
!     TO THE INDIVIDUAL PHYSICAL PARAMETRIZATION

!**   INTERFACE.
!     ----------

!          *SUPHEC* IS CALLED FROM *SUPHY*

!     METHOD.
!     -------

!          NONE.

!     EXTERNALS.
!     ----------

!          *SUECRAD*, *SUCUMF*, *SUCUMF2*,*SUVDFS*, *SUSURF*
!          *SUECRAD15*, *SUCLOP15*
!          *SUGWD*, *SUCLD*, *SUCOND*, *SUPHLI*, *SUMETHOX*

!     REFERENCE.
!     ----------

!          SEE PHYSICAL ROUTINES FOR AN EXACT DEFINITION OF THE
!     CONSTANTS.

!     AUTHOR.
!     -------
!          J.-J. MORCRETTE  E.C.M.W.F.    91/06/15  ADAPTATION TO I.F.S.

!     MODIFICATIONS
!     -------------
!          MAY 1997 : M. Deque  - Frozen FMR
!          APRIL 1998: C. JAKOB - ADD METHANE OXIDATION
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        P.Viterbo     24-May-2004 surf library
!        P.Viterbo     03-Dec-2004 Include user-defined RTHRFRTI
!        M.Ko"hler     03-Dec-2004 cp,moist=cp,dry
!        P.Viterbo     10-Jun-2005 Externalise surf
!        R. El Khatib & J-F Estrade  20-Jan-2005 Default PRSUN for FMR15
!        D.Salmond     22-Nov-2005 Mods for coarser/finer physics
!        P. Lopez      21-Aug-2006 Added call to SUCUMF2 
!                                 (new linearized convec)
!        JJMorcrette   20060525    MODIS albedo
!     ------------------------------------------------------------------

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

USE yomdphy  , ONLY : ntiles 
USE surface_fields, ONLY : ysp_sbd
USE yoelw    , ONLY : nsil     ,tstand   ,xp
USE yoesw    , ONLY : rsun
USE yomsw15  , ONLY : rsun15
USE yomdim   , ONLY : nflevg   ,nsmax, ngpblks, nproma
USE yomgem   , ONLY : vbh      ,vah      ,vp00, vaf   , vbf
USE yomcst   , ONLY : rd       ,rv       ,rcpd     ,&
 & rlvtt    ,rlstt    ,rlmlt    ,rtt      ,ratm 
!USE YOETHF   , ONLY : R2ES     ,R3LES    ,R3IES    ,R4LES    ,&
! & R4IES    ,R5LES    ,R5IES    ,RVTMP2   ,RHOH2O   ,&
! & R5ALVCP  ,R5ALSCP  ,RALVDCP  ,RALSDCP  ,RALFDCP  ,&
! & RTWAT    ,RTBER    ,RTBERCU  ,RTICE    ,RTICECU  ,&
! & RTWAT_RTICE_R      ,RTWAT_RTICECU_R    ,&
! & RKOOP1   ,RKOOP2 
USE yomphy   , ONLY : lrayfm15
!USE YOERAD   , ONLY : NSW      ,NTSW     ,&
! NSW mis dans .def MPL 20140211
USE yoerad   , ONLY : ntsw     ,&
 & lccnl    ,lccno    ,&
 & rccnsea  ,rccnlnd
USE yoe_tile_prop, ONLY : rustrti, rvstrti, rahfsti, revapti, rtskti
USE yoephy   , ONLY : rthrfrti ,leocwa   ,leocco   ,leocsa, le4alb
USE yoevdf   , ONLY : nvtypes
USE yomcoaphy   , ONLY : nphyint
USE yom_phys_grid ,ONLY : phys_grid
USE yomct0  , ONLY  : lscmec   ,lrough   ,rextz0m  ,rextz0h
USE vertical_layers_mod, ONLY: ap,bp

IMPLICIT NONE
include "YOETHF.h"
include "clesphys.h"

INTEGER(KIND=JPIM),INTENT(IN)    :: KULOUT 
INTERFACE
#include "susurf.h"
#include "surf_inq.h"
END INTERFACE

#include "gppre.intfb.h"
#include "sucld.intfb.h"
#include "sucldp.intfb.h"
#include "suclop.intfb.h"
#include "suclop15.intfb.h"
#include "sucond.intfb.h"
#include "sucumf.intfb.h"
#include "sucumf2.intfb.h"
#include "suecrad.intfb.h"
#include "suecrad15.intfb.h"
#include "sugwd.intfb.h"
#include "sumethox.intfb.h"
#include "suphli.intfb.h"
#include "suvdf.intfb.h"
#include "suvdfs.intfb.h"
#include "suwcou.intfb.h"

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

REAL(KIND=JPRB) :: ZPRES(0:nflevg),ZPRESF(nflevg), ZETA(nflevg),ZETAH(0:nflevg)

INTEGER(KIND=JPIM) :: JK,ISMAX,JLEV
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

!*         0.2    DEFINING DERIVED CONSTANTS FROM UNIVERSAL CONSTANTS
!                 ---------------------------------------------------

IF (lhook) CALL dr_hook('SUPHEC',0,zhook_handle)
!CALL GSTATS(1811,0) ! MPL 28.11.08
!RVTMP2=RCPV/RCPD-1.0_JPRB   !use cp,moist
rvtmp2=0.0_jprb              !neglect cp,moist
rhoh2o=ratm/100._jprb
r2es=611.21_jprb*rd/rv
r3les=17.502_jprb
r3ies=22.587_jprb
r4les=32.19_jprb
r4ies=-0.7_jprb
r5les=r3les*(rtt-r4les)
r5ies=r3ies*(rtt-r4ies)
r5alvcp=r5les*rlvtt/rcpd
r5alscp=r5ies*rlstt/rcpd
ralvdcp=rlvtt/rcpd
ralsdcp=rlstt/rcpd
ralfdcp=rlmlt/rcpd
rtwat=rtt
rtber=rtt-5._jprb
rtbercu=rtt-5.0_jprb
rtice=rtt-23._jprb
rticecu=rtt-23._jprb

rtwat_rtice_r=1.0_jprb/(rtwat-rtice)
rtwat_rticecu_r=1.0_jprb/(rtwat-rticecu)
IF(nphyint == 0) THEN
  ismax=nsmax
ELSE
  ismax=phys_grid%NSMAX
ENDIF

rkoop1=2.583_jprb
rkoop2=0.48116e-2_jprb

!     ------------------------------------------------------------------
!*         0.5    DEFINE STANDARD ATMOSPHERE VERTICAL CONFIGURATION
!                 -------------------------------------------------
!ALLOCATE(VBH    (0:MAX(JPMXLE,NFLEVG)))  from suallo.F90
!! 
ALLOCATE(vah(0:nflevg))  ! Ajout ALLOCATE MPL 200509
ALLOCATE(vbh(0:nflevg))
ALLOCATE(vaf(nflevg))
ALLOCATE(vbf(nflevg))
! Commente par MPL 28.11.08, puis decommente le 19.05.09
vp00=101325.     !!!!! A REVOIR (MPL)
zpres(nflevg)=vp00
! on recupere ap et bp de dyn3d (vertical_layers_mod) MPL 19.05.09
! Attention, VAH et VBH sont inverses, comme les niveaux
! plev(l)=PAPRS(klon,nlayer+1-l) de 1 a nlayer (apllmd.F)
DO jlev = 0, nflevg  
!  VAH(JLEV)=ap(JLEV+1)ap(JLEV+1)
!  VBH(JLEV)=bp(JLEV+1)
!  print *,'SUPHEC: jlev ap bp',JLEV,ap(JLEV+1),bp(JLEV+1)
   vah(jlev)=ap(nflevg+1-jlev)
   vbh(jlev)=bp(nflevg+1-jlev)
ENDDO
! Calcul de VAF et VBF, analogues de VAH et VBH mais aux niveaux pleins
DO jlev = 1, nflevg   
   vaf(jlev)=(vah(jlev)+vah(jlev-1))/2.
   vbf(jlev)=(vbh(jlev)+vbh(jlev-1))/2.
ENDDO

! Appel a GPPRE commente par MPL 28.11.08, puis decommente le 19.05.09
CALL gppre ( 1 ,1, 1, nflevg, vah, vbh, zpres, zpresf )

DO jk=0,nflevg
  zetah(jk)= zpres(jk)/zpres(nflevg)
ENDDO
DO jk=1,nflevg
  zeta(jk)= zpresf(jk)/zpres(nflevg)
ENDDO

!     ------------------------------------------------------------------
!*         1.     SETTING CONSTANTS FOR DIAGNOSTIC CLOUD SCHEME
!                 ---------------------------------------------

!CALL SUCLD ( NFLEVG , ZETA ) ! MPL 28.11.08

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

!*         2.     SETTING CONSTANTS FOR LARGE-SCALE CONDENSATION SCHEME
!                 -----------------------------------------------------

!CALL SUCOND ( KULOUT , NFLEVG , ZETA ) ! MPL 28.11.08

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

!*         3.     SETTING CONSTANTS FOR CONVECTION SCHEME
!                 ---------------------------------------

!CALL SUCUMF(ISMAX)     ! MPL 28.11.08

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

!*         3.     SETTING CONSTANTS FOR NEW LINEARIZED CONVECTION SCHEME
!                 ------------------------------------------------------

!CALL SUCUMF2(ISMAX)  ! MPL 28.11.08

!     ------------------------------------------------------------------
!*         4.     SETTING CONSTANTS FOR GRAVITY WAVE DRAG SCHEME
!                 ----------------------------------------------

!CALL SUGWD (KULOUT, NFLEVG, VAH, VBH )   ! MPL 28.11.08

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

!*         5.     SETTING CONSTANTS FOR VERTICAL DIFFUSION
!                 ----------------------------------------

!CALL SUVDFS     ! MPL 28.11.08

!CALL SUVDF      ! MPL 28.11.08

!cccc CALL SUVDFD ( NABLPFR, ABLPLL ) cccccccccccccccccccccccccccccccccc

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

!*         6.     SETTING CONSTANTS FOR RADIATION SCHEME
!                 --------------------------------------

IF (lrayfm15) THEN
  CALL suecrad15 (kulout, nflevg, zetah )
ELSE
  CALL suecrad (kulout, nflevg, zetah )
ENDIF

!     ------------------------------------------------------------------
!*         7.     SETTING CONSTANTS FOR SURFACE SCHEME
!                 ------------------------------------

!IF (LRAYFM15) THEN
!   CALL SUSURF(KSW=NSW,KCSS=YSP_SBD%NLEVS,KSIL=NSIL,KTILES=NTILES,KTSW=NTSW,&
!    & LD_LLCCNL=LCCNL,LD_LLCCNO=LCCNO,&
!    & LD_LEOCWA=LEOCWA,LD_LEOCCO=LEOCCO,LD_LEOCSA=LEOCSA,LD_LLE4ALB=LE4ALB,&
!    & LD_LSCMEC=LSCMEC,LD_LROUGH=LROUGH,PEXTZ0M=REXTZ0M,PEXTZ0H=REXTZ0H,&
!    & PTHRFRTI=RTHRFRTI,PTSTAND=TSTAND,PXP=XP,PRCCNSEA=RCCNSEA,PRCCNLND=RCCNLND,&
!    & PRSUN=RSUN15)
!ELSE
!   CALL SUSURF(KSW=NSW,KCSS=YSP_SBD%NLEVS,KSIL=NSIL,KTILES=NTILES,KTSW=NTSW,&
!    & LD_LLCCNL=LCCNL,LD_LLCCNO=LCCNO,&
!    & LD_LEOCWA=LEOCWA,LD_LEOCCO=LEOCCO,LD_LEOCSA=LEOCSA,LD_LLE4ALB=LE4ALB,&
!    & LD_LSCMEC=LSCMEC,LD_LROUGH=LROUGH,PEXTZ0M=REXTZ0M,PEXTZ0H=REXTZ0H,&
!    & PTHRFRTI=RTHRFRTI,PTSTAND=TSTAND,PXP=XP,PRCCNSEA=RCCNSEA,PRCCNLND=RCCNLND,&
!    & PRSUN=RSUN)
!ENDIF


!CALL SURF_INQ(KNVTYPES=NVTYPES)


!          7.1    Allocate working arrays
!ALLOCATE(RUSTRTI(NPROMA,NTILES,NGPBLKS))
!ALLOCATE(RVSTRTI(NPROMA,NTILES,NGPBLKS))
!ALLOCATE(RAHFSTI(NPROMA,NTILES,NGPBLKS))
!ALLOCATE(REVAPTI(NPROMA,NTILES,NGPBLKS))
!ALLOCATE(RTSKTI (NPROMA,NTILES,NGPBLKS))
!RUSTRTI(:,:,:) = 0.0_JPRB
!RVSTRTI(:,:,:) = 0.0_JPRB
!RAHFSTI(:,:,:) = 0.0_JPRB
!REVAPTI(:,:,:) = 0.0_JPRB
!RTSKTI (:,:,:) = 0.0_JPRB
!CALL GSTATS(1811,1)

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

!*         8.     SETTING CONSTANTS FOR CLOUD OPTICAL PROPERTIES
!                 ----------------------------------------------

IF (lrayfm15) THEN
  CALL suclop15
ELSE
  CALL suclop
ENDIF

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

!*         9.     SETTING CONSTANTS FOR PROGNOSTIC CLOUD SCHEME
!                 ----------------------------------------------

!CALL SUCLDP

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

!*        10.     SETTING CONSTANTS FOR WAVE COUPLING
!                 -----------------------------------

!CALL SUWCOU

!     ------------------------------------------------------------------
!*         11.   SETTING CONSTANTS FOR LINEARIZED PHYSICS
!                ----------------------------------------

!CALL SUPHLI

!     ------------------------------------------------------------------
!*         12.   SETTING CONSTANTS FOR METHANE OXIDATION
!                ---------------------------------------

!CALL SUMETHOX

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

WRITE(unit=kulout,fmt='('' SUPHEC IS OVER '')')

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

IF (lhook) CALL dr_hook('SUPHEC',1,zhook_handle)
END SUBROUTINE suphec