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
!     ------------------------------------------------------------------

#include "tsmbkind.h"

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     ,&
            &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


!     DUMMY INTEGER SCALARS
integer_m :: kdat
integer_m :: kprintlev
integer_m :: ksss
integer_m :: kulout


!     LOCAL INTEGER SCALARS
integer_m :: ia, id, idat, im, isss, j

!     LOCAL REAL SCALARS
real_b :: zde, zet, zju, zrs, zrsrel, zteta, zti


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

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


rpi=_two_*asin(_one_)
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*_two_*rpi/6.283076_jprb
rsiday=rday/(_one_+rday/rsiyea)
romega=_two_*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(_ONE_/REAL(RA,KIND(_ONE_)),KIND(r1sa))

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

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

rsigma=_two_ * 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-_one_

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

!*       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)
rgams=(rcs-rcpv)/rv
rbets=rlstt/rv+rgams*rtt
ralps=log(restt)+rbets/rtt+rgams*log(rtt)
rgamd=rgams-rgamw
rbetd=rbets-rbetw
ralpd=ralps-ralpw

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

!*      10.    PRINTS

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)
  WRITE(kulout,'(10(1X,E10.4))') (es(rtt+10._jprb*j),j=-4,4)
ENDIF

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

RETURN
END SUBROUTINE sucst