sucst.F90

Go to the documentation of this file.

SUBROUTINE sucst(KULOUT,KDAT,KSSS,KPRINTLEV)

!**** *SUCST * - Routine to initialize the constants of the model.

!     Purpose.
!     --------
!           Initialize and print the common YOMCST + initialize
!         date and time of YOMRIP.

!**   Interface.
!     ----------
!        *CALL* *SUCST (..)

!        Explicit arguments :
!        --------------------

!        KULOUT  - logical unit for the output
!        KDAT    - date in the form AAAAMMDD
!        KSSS    - number of seconds in the day
!        KPRINTLEV - printing level

!        Implicit arguments :
!        --------------------
!        COMMON YOMCST
!        COMMON YOMRIP

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

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

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        Mats Hamrud and Philippe Courtier  *ECMWF*

!     Modifications.
!     --------------
!        Original : 87-10-15
!        Additions : 90-07-30 (J.-F. Geleyn)
!                    91-11-15 (M. Deque)
!                    96-08-12 M.Hamrud - Reduce printing
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE yomcst   , ONLY : rpi      ,rclum    ,rhpla    ,rkbol    ,&
 & rnavo    ,rday     ,rea      ,repsm    ,rsiyea   ,&
 & rsiday   ,romega   ,ra       ,rg       ,r1sa     ,&
 & rsigma   ,ri0      ,r        ,rmd      ,rmv      ,&
 & rmo3     ,rd       ,rv       ,rcpd     ,rcpv     ,&
 & rmco2    ,rmch4    ,rmn2o    ,rmco     ,rmhcho   ,&
 & rmso2    ,rmno2    ,rmsf6    ,rmra     ,&
 & rcvd     ,rcvv     ,rkappa   ,retv     ,rcw      ,&
 & rcs      ,rlvtt    ,rlstt    ,rlvzer   ,rlszer   ,&
 & rlmlt    ,rtt      ,ratm     ,rdt      ,restt    ,&
 & ralpw    ,rbetw    ,rgamw    ,ralps    ,rbets    ,&
 & rgams    ,ralpd    ,rbetd    ,rgamd  
USE yomrip   , ONLY : rtimst   ,rtimtr

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KULOUT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDAT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSSS 
INTEGER(KIND=JPIM),INTENT(IN)    :: KPRINTLEV 
INTEGER(KIND=JPIM) :: IA, ID, IDAT, IM, ISSS, J

REAL(KIND=JPRB) :: ZDE, ZET, ZJU, ZRS, ZRSREL, ZTETA, ZTI
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "fctast.h"
#include "fcttrm.h"
#include "fcttim.h"
!      -----------------------------------------------------------------

!*       1.    DEFINE FUNDAMENTAL CONSTANTS.
!              -----------------------------

print*,'DANS SUCST CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
IF (lhook) CALL dr_hook('SUCST',0,zhook_handle)
rpi=2.0_jprb*asin(1.0_jprb)
rclum=299792458._jprb
rhpla=6.6260755e-34_jprb
rkbol=1.380658e-23_jprb
rnavo=6.0221367e+23_jprb

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

!*       2.    DEFINE ASTRONOMICAL CONSTANTS.
!              ------------------------------

rday=86400._jprb
rea=149597870000._jprb
repsm=0.409093_jprb

rsiyea=365.25_jprb*rday*2.0_jprb*rpi/6.283076_jprb
rsiday=rday/(1.0_jprb+rday/rsiyea)
romega=2.0_jprb*rpi/rsiday

idat=kdat
isss=ksss
id=ndd(idat)
im=nmm(idat)
ia=nccaa(idat)
zju=rjudat(ia,im,id)
zti=rtime(ia,im,id,isss)
rtimst=zti
rtimtr=zti
zteta=rteta(zti)
zrs=rrs(zteta)
zde=rds(zteta)
zet=ret(zteta)
zrsrel=zrs/rea

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

!*       3.    DEFINE GEOIDE.
!              --------------

rg=9.80665_jprb
ra=6371229._jprb
r1sa=REAL(1.0_JPRB/REAL(RA,KIND(1.0_JPRB)),KIND(r1sa))

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

!*       4.    DEFINE RADIATION CONSTANTS.
!              ---------------------------

rsigma=2.0_jprb * rpi**5 * rkbol**4 /(15._jprb* rclum**2 * rhpla**3)
ri0=1370._jprb

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

!*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
!              ------------------------------------------

r=rnavo*rkbol
rmd=28.9644_jprb
rmv=18.0153_jprb
rmo3=47.9942_jprb
rd=1000._jprb*r/rmd
rv=1000._jprb*r/rmv
rcpd=3.5_jprb*rd
rcvd=rcpd-rd
rcpv=4._jprb *rv
rcvv=rcpv-rv
rkappa=rd/rcpd
retv=rv/rd-1.0_jprb
rmco2=44.0095_jprb
rmch4=16.04_jprb
rmn2o=44.013_jprb
rmsf6=146.05_jprb
rmra=222._jprb
rmco=28.01_jprb
rmhcho=30.03_jprb
rmno2=46.01_jprb
rmso2=64.07_jprb

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

!*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
!              ---------------------------------------------

rcw=4218._jprb

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

!*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
!              --------------------------------------------

rcs=2106._jprb

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

!*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
!              ----------------------------------------------------

rtt=273.16_jprb
rdt=11.82_jprb
rlvtt=2.5008e+6_jprb
rlstt=2.8345e+6_jprb
rlvzer=rlvtt+rtt*(rcw-rcpv)
rlszer=rlstt+rtt*(rcs-rcpv)
rlmlt=rlstt-rlvtt
ratm=100000._jprb

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

!*       9.    SATURATED VAPOUR PRESSURE.
!              --------------------------

restt=611.14_jprb
rgamw=(rcw-rcpv)/rv
rbetw=rlvtt/rv+rgamw*rtt
ralpw=log(restt)+rbetw/rtt+rgamw*log(rtt)
print *,'SUCST: RESTT,RBETW,RTT,RGAMW',restt,rbetw,rtt,rgamw
print *,'SUCST: RALPW',ralpw
rgams=(rcs-rcpv)/rv
rbets=rlstt/rv+rgams*rtt
ralps=log(restt)+rbets/rtt+rgams*log(rtt)
print *,'SUCST: RESTT,RBETS,RTT,RGAMS',restt,rbets,rtt,rgams
print *,'SUCST: RALPS',ralps
rgams=(rcs-rcpv)/rv
rgamd=rgams-rgamw
rbetd=rbets-rbetw
ralpd=ralps-ralpw

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

!*      10.    PRINTS

print*,'KPRINTLEV ',kprintlev
print*,'KULOUT ',kulout

IF (kprintlev >= 1) THEN
  WRITE(kulout,'(''0*** Constants of the ICM   ***'')')
  WRITE(kulout,'('' *** Fundamental constants ***'')')
  WRITE(kulout,'(''           PI = '',E13.7,'' -'')')rpi
  WRITE(kulout,'(''            c = '',E13.7,''m s-1'')')rclum
  WRITE(kulout,'(''            h = '',E13.7,''J s'')')rhpla
  WRITE(kulout,'(''            K = '',E13.7,''J K-1'')')rkbol
  WRITE(kulout,'(''            N = '',E13.7,''mol-1'')')rnavo
  WRITE(kulout,'('' *** Astronomical constants ***'')')
  WRITE(kulout,'(''          day = '',E13.7,'' s'')')rday
  WRITE(kulout,'('' half g. axis = '',E13.7,'' m'')')rea
  WRITE(kulout,'('' mean anomaly = '',E13.7,'' -'')')repsm
  WRITE(kulout,'('' sideral year = '',E13.7,'' s'')')rsiyea
  WRITE(kulout,'(''  sideral day = '',E13.7,'' s'')')rsiday
  WRITE(kulout,'(''        omega = '',E13.7,'' s-1'')')romega

  WRITE(kulout,'('' The initial date of the run is :'')')
  WRITE(kulout,'(1X,I8,1X,I5,5X,I4,1X,I2,1X,I2)')idat,isss,ia,im,id
  WRITE(kulout,'('' The Julian date is : '',F11.2)') zju
  WRITE(kulout,'('' Time of the model  : '',F15.2,'' s'')')zti
  WRITE(kulout,'('' Distance Earth-Sun : '',E13.7,'' m'')')zrs
  WRITE(kulout,'('' Relative Dist. E-S : '',E13.7,'' m'')')zrsrel
  WRITE(kulout,'('' Declination        : '',F12.5)') zde
  WRITE(kulout,'('' Eq. of time        : '',F12.5,'' s'')')zet
  WRITE(kulout,'('' ***         Geoide         ***'')')
  WRITE(kulout,'(''      Gravity = '',E13.7,'' m s-2'')')rg
  WRITE(kulout,'('' Earth radius = '',E13.7,'' m'')')ra
  WRITE(kulout,'('' Inverse E.R. = '',E13.7,'' m'')')r1sa
  WRITE(kulout,'('' ***        Radiation       ***'')')
  WRITE(kulout,'('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4'')')  rsigma
  WRITE(kulout,'('' Solar const. = '',E13.7,'' W m-2'')')ri0
  WRITE(kulout,'('' *** Thermodynamic, gas     ***'')')
  WRITE(kulout,'('' Perfect gas  = '',e13.7)') r
  WRITE(kulout,'('' Dry air mass = '',e13.7)') rmd
  WRITE(kulout,'('' Vapour  mass = '',e13.7)') rmv
  WRITE(kulout,'('' Ozone   mass = '',e13.7)') rmo3
  WRITE(kulout,'('' Dry air cst. = '',e13.7)') rd
  WRITE(kulout,'('' Vapour  cst. = '',e13.7)') rv
  WRITE(kulout,'(''         Cpd  = '',e13.7)') rcpd
  WRITE(kulout,'(''         Cvd  = '',e13.7)') rcvd
  WRITE(kulout,'(''         Cpv  = '',e13.7)') rcpv
  WRITE(kulout,'(''         Cvv  = '',e13.7)') rcvv
  WRITE(kulout,'(''      Rd/Cpd  = '',e13.7)') rkappa
  WRITE(kulout,'(''     Rv/Rd-1  = '',e13.7)') retv
  WRITE(kulout,'('' *** Thermodynamic, liquid  ***'')')
  WRITE(kulout,'(''         Cw   = '',E13.7)') rcw
  WRITE(kulout,'('' *** thermodynamic, solid   ***'')')
  WRITE(kulout,'(''         Cs   = '',E13.7)') rcs
  WRITE(kulout,'('' *** Thermodynamic, trans.  ***'')')
  WRITE(kulout,'('' Fusion point  = '',E13.7)') rtt
  WRITE(kulout,'('' RTT-Tx(ew-ei) = '',E13.7)') rdt
  WRITE(kulout,'(''        RLvTt  = '',E13.7)') rlvtt
  WRITE(kulout,'(''        RLsTt  = '',E13.7)') rlstt
  WRITE(kulout,'(''        RLv0   = '',E13.7)') rlvzer
  WRITE(kulout,'(''        RLs0   = '',E13.7)') rlszer
  WRITE(kulout,'(''        RLMlt  = '',E13.7)') rlmlt
  WRITE(kulout,'('' Normal press. = '',E13.7)') ratm
  WRITE(kulout,'('' Latent heat :  '')')
  WRITE(kulout,'(10(1X,E10.4))') (10._jprb*j,j=-4,4)
  WRITE(kulout,'(10(1X,E10.4))') (rlv(rtt+10._jprb*j),j=-4,4)
  WRITE(kulout,'(10(1X,E10.4))') (rls(rtt+10._jprb*j),j=-4,4)
  WRITE(kulout,'('' *** Thermodynamic, satur.  ***'')')
  WRITE(kulout,'('' Fusion point = '',E13.7)') rtt
  WRITE(kulout,'(''      es(Tt)  = '',e13.7)') restt
  WRITE(kulout,'('' es(T) :  '')')
  WRITE(kulout,'(10(1X,E10.4))') (10._jprb*j,j=-4,4)
  WRITE(kulout,'(10(1X,E10.4))') (esw(rtt+10._jprb*j),j=-4,4)
  WRITE(kulout,'(10(1X,E10.4))') (ess(rtt+10._jprb*j),j=-4,4)
!  call flush(0)       !!!!! A REVOIR (MPL) les 7 lignes qui suivent
   do j=1,9
     print*,'TEST J',j
     print*,'RTT...',rtt+10._jprb*(j-5)
     print*,'ES(RTT...',es(rtt+10._jprb*(j-5))
   enddo
  call flush(0)

  WRITE(kulout,'(10(1X,E10.4))') (es(rtt+10._jprb*j),j=-4,4)
ENDIF

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

IF (lhook) CALL dr_hook('SUCST',1,zhook_handle)
END SUBROUTINE sucst