*=*=*=*= SUCST.html =*=*=*=*
SUBROUTINE SUCST

SUBROUTINE SUCST


      SUBROUTINE SUCST(KULOUT,KDAT,KSSS,pg,prad,pmugaz,pkappa,
     s   pdaysec)
C
C**** *SUCST * - Routine to initialize the constants of the model.
C
C     Purpose.
C     --------
C           Initialize and print the common YOMCST + initialize
C         date and time of YOMRIP.
C
C**   Interface.
C     ----------
C        *CALL* *SUCST (kulout,kdat,ksss)
C
C        Explicit arguments :
C        --------------------
C
C        KULOUT logical unit for the output
C        KDAT   date in the form AAAAMMDD
C        KSSS   number of seconds in the day
C
C        Implicit arguments :
C        --------------------
C        COMMON YOMCST
C
C     Method.
C     -------
C        See documentation
C
C     Externals.
C     ----------
C
C     Reference.
C     ----------
C        ECMWF research department documentation of the
C     "in core model"
C
C     Author.
C     -------
C        Mats Hamrud and Philippe Courtier  *ECMWF*
C
C     Modifications.
C     --------------
C        Original : 87-10-15
C     ------------------------------------------------------------------
#include "planete.h"
#include "yomcst.h"
#include "yomrip.h"

      REAL pg,prad,pmugaz,pkappa,pdaysec

C      -----------------------------------------------------------
C
C - Astronomical functions
C you will find the description in the annex 1 of the documentation
C RRS is the distance Sun-Earth
C RDS is the declination of the Earth
C RET is the equation of time
C
C Orbit of the earth
      RTETA(PTIME)=PTIME/(RDAY*365.25)
      REL(PTETA)=1.7535+6.283076*PTETA
      REM(PTETA)=6.240075+6.283020*PTETA
      RRS(PTETA)=REA*(1.0001-0.0163*SIN(REL(PTETA))
     S           +0.0037*COS(REL(PTETA)))
C Relative movement Sun/Earth
      RLLS(PTETA)=4.8951+6.283076*PTETA
      RLLLS(PTETA)=4.8952+6.283320*PTETA-0.0075*SIN(REL(PTETA))
     S          -0.0326*COS(REL(PTETA))-0.0003*SIN(2.*REL(PTETA))
     S          +0.0002*COS(2.*REL(PTETA))
      RDS(PTETA)=ASIN(SIN(REPSM)*SIN(RLLLS(PTETA)))
      RET(PTETA)=591.8*SIN(2.*RLLS(PTETA))-459.4*SIN(REM(PTETA))
     S   +39.5*SIN(REM(PTETA))*COS(2.*RLLS(PTETA))
     S   -12.7*SIN(4.*RLLS(PTETA))-4.8*SIN(2.*REM(PTETA))
C    -------------------------------------------------------------
C     ------------------------------------------------------------
C
C - thermodynamical functions
C
C RLV : Latent heat of vapourisation
C RLS : Latent heat of sublimation
C RLF : Latent heat of fusion
C ESW : saturation in presence of water
C ESS : saturation in presence of ice
C ES  : saturation (T>Tt then water TRLV(QQQQQT)=RLVTT+(RCPV-RCW)*(QQQQQT-RTT)
      RLS(QQQQQT)=RLSTT+(RCPV-RCS)*(QQQQQT-RTT)
      RLF(QQQQQT)=RLS(QQQQQT)-RLV(QQQQQT)
      ESW(QQQQQT)=EXP(RALPW-RBETW/QQQQQT-RGAMW*ALOG(QQQQQT))
      ESS(QQQQQT)=EXP(RALPS-RBETS/QQQQQT-RGAMS*ALOG(QQQQQT))
      EZZ(QQQQQT,QQQQQA,QQQQQB)=(.5+SIGN(.5,QQQQQT-RTT))*QQQQQA
     s                         +(.5-SIGN(.5,QQQQQT-RTT))*QQQQQB
      ES (QQQQQT)=EXP(EZZ(QQQQQT,RALPW,RALPS)
     s               -EZZ(QQQQQT,RBETW,RBETS)/QQQQQT
     s               -EZZ(QQQQQT,RGAMW,RGAMS)*ALOG(QQQQQT) )
C    -------------------------------------------------------------
C     ------------------------------------------------------------
C
C - Time functions
C   the descriptions are in the annex 1 of the documentation
C
C TIME
C
C NDD   : extraxt dd from ccaammdd
C NMM   : extract mm from ccaammdd
C NAA   : extract aa from ccaammdd
C NCCAA : extract ccaa from ccaammdd
C NAMD  : extract aammdd from ccaammdd
C NCTH  : turn seconds into hours
C RTIME : returns the time of the model (in seconds of course!)
C
      NDD(KGRDAT)  =MOD(KGRDAT,100)
      NMM(KGRDAT)  =MOD((KGRDAT-NDD(KGRDAT))/100,100)
      NCCAA(KGRDAT)=KGRDAT/10000
      NAA(KGRDAT)=MOD(NCCAA(KGRDAT),100)
      NAMD(KGRDAT)=MOD(KGRDAT,1000000)
      NCTH(KSEC)=KSEC/3600
C
      NZZAA(KAAAA,KMM)=KAAAA-( (1-ISIGN(1,KMM-3))/2 )
      NZZMM(KMM)=KMM+6*(1-ISIGN(1,KMM-3))
      RJUDAT(KAAAA,KMM,KDD)=1720994.5 + FLOAT(
     S   2-NZZAA(KAAAA,KMM)/100 + (NZZAA(KAAAA,KMM)/100)/4
     S + INT(365.25*FLOAT(NZZAA(KAAAA,KMM)))
     S + INT(30.601*FLOAT(NZZMM(KMM)+1))
     S + KDD)
      RTIME(KAAAA,KMM,KDD,KSS)=(RJUDAT(KAAAA,KMM,KDD)-2451545.)
     S     *RDAY+FLOAT(KSS)
C    -------------------------------------------------------------
C      -----------------------------------------------------------------
C
C*       1.    DEFINE FUNDAMENTAL CONSTANTS.
C              -----------------------------
C
 100  CONTINUE
C
      WRITE(UNIT=KULOUT,FMT='(''0*** Constants of the ICM   ***'')')
      RPI=2.*ASIN(1.)
      RCLUM=299792458.
      RHPLA=6.6260755E-34
      RKBOL=1.380658E-23
      RNAVO=6.0221367E+23
      WRITE(UNIT=KULOUT,FMT='('' *** Fundamental constants ***'')')
      WRITE(UNIT=KULOUT,FMT='(''           PI = '',E13.7,'' -'')')RPI
      WRITE(UNIT=KULOUT,FMT='(''            c = '',E13.7,''m s-1'')')
     S RCLUM
      WRITE(UNIT=KULOUT,FMT='(''            h = '',E13.7,''J s'')')
     S RHPLA
      WRITE(UNIT=KULOUT,FMT='(''            K = '',E13.7,''J K-1'')')
     S RKBOL
      WRITE(UNIT=KULOUT,FMT='(''            N = '',E13.7,''mol-1'')')
     S RNAVO
C
C     ----------------------------------------------------------------
C
C*       2.    DEFINE ASTRONOMICAL CONSTANTS.
C              ------------------------------
C
 200  CONTINUE
C
C     RDAY=86400.
C     REA=149597870000.
C     REPSM=0.409093
C
      RDAY=pdaysec
c   !!! les deux parametres suivants sont a changer mais pas utilises
      REA=246280000000.
      REPSM=0.409093
C
c   !!! a changer egalement
      RSIYEA=365.25*RDAY*2.*RPI/6.283076
      RSIDAY=RDAY/(1.+RDAY/RSIYEA)
      ROMEGA=2.*RPI/RSIDAY
      WRITE(UNIT=KULOUT,FMT='('' *** Astronomical constants ***'')')
      WRITE(UNIT=KULOUT,FMT='(''          day = '',E13.7,'' s'')')RDAY
      WRITE(UNIT=KULOUT,FMT='('' half g. axis = '',E13.7,'' m'')')REA
      WRITE(UNIT=KULOUT,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM
      WRITE(UNIT=KULOUT,FMT='(''  sideral day = '',E13.7,'' s'')')RSIDAY
      WRITE(UNIT=KULOUT,FMT='(''        omega = '',E13.7,'' s-1'')')
     S                  ROMEGA
C
      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
      WRITE(UNIT=KULOUT,FMT='('' The initial date of the run is :'')')
      WRITE(UNIT=KULOUT,FMT='(1X,I8,1X,I5,5X,I4,1X,I2,1X,I2)')
     S      IDAT,ISSS,IA,IM,ID
      WRITE(UNIT=KULOUT,FMT='('' The Julian date is : '',F11.2)') ZJU
      WRITE(UNIT=KULOUT,FMT='('' Time of the model  : '',F15.2,'' s'')')
     S      ZTI
      ZTETA=RTETA(ZTI)
      ZRS=RRS(ZTETA)
      ZDE=RDS(ZTETA)
      ZET=RET(ZTETA)
      WRITE(UNIT=KULOUT,FMT='('' Distance Earth-Sun : '',E13.7,'' m'')')
     S      ZRS
      WRITE(UNIT=KULOUT,FMT='('' Declination        : '',F12.5)') ZDE
      WRITE(UNIT=KULOUT,FMT='('' Eq. of time        : '',F12.5,'' s'')')
     S      ZET
C
C     ------------------------------------------------------------------
C
C*       3.    DEFINE GEOIDE.
C              --------------
C
 300  CONTINUE
C
      RG=pg
      RA=prad
      R1SA=SNGL(1.D0/DBLE(RA))
      WRITE(UNIT=KULOUT,FMT='('' ***         Geoide         ***'')')
      WRITE(UNIT=KULOUT,FMT='(''      Gravity = '',E13.7,'' m s-2'')')
     S      RG
      WRITE(UNIT=KULOUT,FMT='('' Earth radius = '',E13.7,'' m'')')RA
C
C     -----------------------------------------------------------------
C
C*       4.    DEFINE RADIATION CONSTANTS.
C              ---------------------------
C
 400  CONTINUE
C
C     RSIGMA=2. * RPI**5 * RKBOL**4 /(15 * RCLUM**2 * RHPLA**3)
      RSIGMA=1.e-6 * 2. * RPI**5 *(RKBOL*1.e+23)**4 /
     $   (15 *(RCLUM*1.e-8)**2 * (RHPLA*1.e+34)**3)
      RI0=1370.
      WRITE(UNIT=KULOUT,FMT='('' ***        Radiation       ***'')')
      WRITE(UNIT=KULOUT,FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4''
     S )')  RSIGMA
      WRITE(UNIT=KULOUT,FMT='('' Solar const. = '',E13.7,'' W m-2'')')
     S      RI0
C
C     -----------------------------------------------------------------
C
C*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
C              ------------------------------------------
C
 500  CONTINUE
C
      R=RNAVO*RKBOL
      RMD=pmugaz
c   !!! masse moleculaire de la vapeur d'eau
c   les suffixes V correspondent a la vapeur d'eau
      RMV=18.0153
      RD=1000.*R/RMD
      RV=1000.*R/RMV
      RCPD=RD/pkappa
      RCVD=RCPD-RD
      RCPV=4. *RV
      RCVV=RCPV-RV
      RDELTA=RCPV/RCPD
      RDELM1=RDELTA-1.
      RKAPPA=RD/RCPD
      REPSI=RD/RV
      R1M1E=1./REPSI-1.
      WRITE(UNIT=KULOUT,FMT='('' *** Thermodynamic, gas     ***'')')
      WRITE(UNIT=KULOUT,FMT='('' Perfect gas  = '',e13.7)') R
      WRITE(UNIT=KULOUT,FMT='('' Dry air mass = '',e13.7)') RMD
      WRITE(UNIT=KULOUT,FMT='('' Vapour  mass = '',e13.7)') RMV
      WRITE(UNIT=KULOUT,FMT='('' Dry air cst. = '',e13.7)') RD
      WRITE(UNIT=KULOUT,FMT='('' Vapour  cst. = '',e13.7)') RV
      WRITE(UNIT=KULOUT,FMT='(''         Cpd  = '',e13.7)') RCPD
      WRITE(UNIT=KULOUT,FMT='(''         Cvd  = '',e13.7)') RCVD
      WRITE(UNIT=KULOUT,FMT='(''         Cpv  = '',e13.7)') RCPV
      WRITE(UNIT=KULOUT,FMT='(''         Cvv  = '',e13.7)') RCVV
C
C     ----------------------------------------------------------------
C
C*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
C              ---------------------------------------------
C
 600  CONTINUE
C
      RCW=4218.
      WRITE(UNIT=KULOUT,FMT='('' *** Thermodynamic, liquid  ***'')')
      WRITE(UNIT=KULOUT,FMT='(''         Cw   = '',E13.7)') RCW
C
C     ----------------------------------------------------------------
C
C*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
C              --------------------------------------------
C
 700  CONTINUE
C
      RCS=2106.
      WRITE(UNIT=KULOUT,FMT='('' *** thermodynamic, solid   ***'')')
      WRITE(UNIT=KULOUT,FMT='(''         Cs   = '',E13.7)') RCS
C
C     ----------------------------------------------------------------
C
C*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
C              ----------------------------------------------------
C
 800  CONTINUE
C
      RTT=273.16
      RLVTT=2.5008E+6
      RLSTT=2.8345E+6
      RATM=100000.
      WRITE(UNIT=KULOUT,FMT='('' *** Thermodynamic, trans.  ***'')')
      WRITE(UNIT=KULOUT,FMT='('' Fusion point = '',E13.7)') RTT
      WRITE(UNIT=KULOUT,FMT='(''        RLvTt  = '',E13.7)') RLVTT
      WRITE(UNIT=KULOUT,FMT='(''        RLsTt  = '',E13.7)') RLSTT
      WRITE(UNIT=KULOUT,FMT='('' Normal press. = '',E13.7)') RATM
      WRITE(UNIT=KULOUT,FMT='('' Latent heat :  '')')
      WRITE(UNIT=KULOUT,FMT='(10(1X,E10.4))') (10.*I,I=-4,4)
      WRITE(UNIT=KULOUT,FMT='(10(1X,E10.4))') (RLV(RTT+10.*I),I=-4,4)
      WRITE(UNIT=KULOUT,FMT='(10(1X,E10.4))') (RLS(RTT+10.*I),I=-4,4)
C
C     ----------------------------------------------------------------
C
C*       9.    SATURATED VAPOUR PRESSURE.
C              --------------------------
C
 900  CONTINUE
C
      RESTT=611.14
      RGAMW=(RCW-RCPV)/RV
      RBETW=RLV(RTT)/RV+RGAMW*RTT
      RALPW=ALOG(RESTT)+RBETW/RTT+RGAMW*ALOG(RTT)
      RGAMS=(RCS-RCPV)/RV
      RBETS=RLS(RTT)/RV+RGAMS*RTT
      RALPS=ALOG(RESTT)+RBETS/RTT+RGAMS*ALOG(RTT)
      WRITE(UNIT=KULOUT,FMT='('' *** Thermodynamic, satur.  ***'')')
      WRITE(UNIT=KULOUT,FMT='('' Fusion point = '',E13.7)') RTT
      WRITE(UNIT=KULOUT,FMT='(''      es(Tt)  = '',e13.7)') RESTT
      WRITE(UNIT=KULOUT,FMT='('' es(T) :  '')')
      WRITE(UNIT=KULOUT,FMT='(10(1X,E10.4))') (10.*I,I=-4,4)
      WRITE(UNIT=KULOUT,FMT='(10(1X,E10.4))') (ESW(RTT+10.*I),I=-4,4)
      WRITE(UNIT=KULOUT,FMT='(10(1X,E10.4))') (ESS(RTT+10.*I),I=-4,4)
      WRITE(UNIT=KULOUT,FMT='(10(1X,E10.4))') (ES (RTT+10.*I),I=-4,4)
C
C     ------------------------------------------------------------------
C
      RETURN
      END