!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE SUCST(KULOUT) 1,1
C
C**** *SUCST * - Routine to initialize the constants of the model.
C
C Purpose.
C --------
C Initialize and print the common YOMCST
C
C Author.
C -------
C Mats Hamrud and Philippe Courtier *ECMWF*
C
C Revision:
C JM Belanger CMDA/SMC Aug 2000
C . 32 bits conversion
C (enforce double precision constants)
C
C Modifications.
C --------------
C Original : 87-10-15
C Additions : 90-07-30 (J.-F. Geleyn)
C Modifications: 92-05-15 (P. Gauthier *ARMA/AES)
C 94-03-10 (p. KOCLAS CMC/CMDA) RPECIS (NEC)
C 97-11-24 (p. KOCLAS CMC/CMDA) NR8SIZ
C 98-11-19 (c.charette *ARMA/AES) RMBTPA,RPATMB.
C Initialize thermodynamics constants.
C RG,RD changed to match GRAV,RGASD
C from thermodynamics constants
C S. Pellerin *ARMA/SMC May 2000
C . introduction of specific humidity threshold and
C t-td max
C
C L. Fillion - ARMA/MSC - 5 July 05: Add further thermodynamical constants.
C L. Fillion ARMA/MSC May 2006: Mesovar upgrade to v10_0_0.
C L. Fillion ARMA/EC - 15 Aug 2007 - Update lam4d to v_10_0_3.
C
C ------------------------------------------------------------------
IMPLICIT NONE
#include "comcst.cdk"
#include "comphy.cdk"
INTEGER KULOUT
INTEGER QQQR8SZ
C -----------------------------------------------------------------
C
C* 1. Define fundamental constants.
C . -----------------------------
C
100 CONTINUE
C
WRITE(UNIT=KULOUT,FMT='(//,4x
S ,"- SUCST: definition of Physical constants ***",/)')
RPI=2.0D0*ASIN(1.0D0)
RCLUM=299792458.D0
RHPLA=6.6260755D-34
RKBOL=1.380658D-23
RNAVO=6.0221367D+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
RDAY=86400.D0
REA=149597870000.D0
REPSM=0.409093D0
C
RSIYEA=365.25D0*RDAY*2.*RPI/6.283076D0
RSIDAY=RDAY/(1.D0+RDAY/RSIYEA)
ROMEGA=2.D0*RPI/RSIDAY
C
WRITE(UNIT=KULOUT,FMT='(" *** ASTRONOMICAL CONSTANTS ***")')
WRITE(UNIT=KULOUT,FMT='(" Day (RDAY) = "
S ,E13.7," s")')RDAY
WRITE(UNIT=KULOUT,FMT='(" Half g. Axis (REA) = "
S ,E13.7," m")')REA
WRITE(UNIT=KULOUT,FMT='(" Mean Anomaly (REPSM) = "
S ,E13.7," -")')REPSM
WRITE(UNIT=KULOUT,FMT='(" Sideral Year (RSIYEA) = "
S ,E13.7," s")')RSIYEA
WRITE(UNIT=KULOUT,FMT='(" Sideral Day (RSIDAY) = "
S ,E13.7," s")')RSIDAY
WRITE(UNIT=KULOUT,FMT='(" Omega (ROMEGA) = "
S ,E13.7," s-1")')ROMEGA
C
C
C* 3. Define geoid
C . ------------
C
300 CONTINUE
C
RG=9.80616D0
RA=6371229.D0
cjmb R1SA=SNGL(1.D0/DBLE(RA))
R1SA=1.D0/DBLE(RA)
C
WRITE(UNIT=KULOUT,FMT='(" *** GEOID ***")')
WRITE(UNIT=KULOUT,FMT='(" Gravity (RG) = "
S ,E13.7," m s-2")') RG
WRITE(UNIT=KULOUT,FMT='(" Earth radius (RA) = "
S ,E13.7," m")')RA
WRITE(UNIT=KULOUT,FMT='(" Inverse E.R. (R1SA) = "
S ,E13.7," m")')R1SA
C
C* 4. Define radiation constants.
C . ---------------------------
400 CONTINUE
C
RSIGMA = 5.66961D-8
RI0=1370.D0
C
WRITE(UNIT=KULOUT,FMT='(" *** RADIATION ***")')
WRITE(UNIT=KULOUT,FMT='(" Stefan-Bol. (RSIGMA) = "
S ,E13.7," W m-2 K-4")') RSIGMA
WRITE(UNIT=KULOUT,FMT='(" Solar const. (RIO) = "
S ,E13.7," W m-2")') RI0
C
C* 5. Define thermodynamic constants, gas phase.
C . ------------------------------------------
C
500 CONTINUE
C
R = RNAVO*RKBOL
RMD = 28.9644D0
RMV = 18.0153D0
ccc RD = 1000.D0*R/RMD
RD = 287.05D0
RV = 1000.D0*R/RMV
RCPD = 3.5D0*RD
RCVD = RCPD-RD
RCPV = 4.D0 *RV
RCVV = RCPV-RV
RKAPPA = RD/RCPD
RETV = RV/RD-1.D0
RTRPL = 0.2731600000000E+03
RCHLC = 0.2501000000000E+07
RCHLF = 0.3340000000000E+06
RCHLS = 0.28340000000000E+07
EPS1 = RD/RV
EPS2 = 1.d0 - EPS1
DELTA = 1.d0/EPS1 - 1.d0
C
C 5.1 liquid phase
C
RHOW = 1.0e3
C
C 5.2 Useful thermodynamic constants
C
REPSI = RMV/RMD
C
C 6. Definition of constants used in units conversion
C . ------------------------------------------------
C
600 CONTINUE
RKNTMS = 1.94246D0
cjmb RMSKNT = SNGL(1.D0/DBLE(RKNTMS))
RMSKNT = 1.D0/DBLE(RKNTMS)
RMBTPA = 1.0D2
RPATMB = 1.0D-2
RGZ = 1.0d1*rg
RDECAM = 1.D0/RGZ
rdeg2rad=rpi/180.
rrad2deg=1.D0/rdeg2rad
C
WRITE(UNIT=KULOUT,FMT='(" *** THERMODYNAMIC, GAS ***")')
WRITE(UNIT=KULOUT,FMT='(" Perfect gas (R) = "
S ,e13.7)') R
WRITE(UNIT=KULOUT,FMT='(" Dry air mass (RMD) = "
S ,e13.7)') RMD
WRITE(UNIT=KULOUT,FMT='(" Vapour mass (RMV) = "
S ,e13.7)') RMV
WRITE(UNIT=KULOUT,FMT='(" Dry air cst. (RD) = "
S ,e13.7)') RD
WRITE(UNIT=KULOUT,FMT='(" Vapour cst. (RV) = "
S ,e13.7)') RV
WRITE(UNIT=KULOUT,FMT='(" Cpd (RCPD) = "
S ,e13.7)') RCPD
WRITE(UNIT=KULOUT,FMT='(" Cvd (RCVD) = "
S ,e13.7)') RCVD
WRITE(UNIT=KULOUT,FMT='(" Cpv (RCPV) = "
S ,e13.7)') RCPV
WRITE(UNIT=KULOUT,FMT='(" Cvv (RCVV) = "
S ,e13.7)') RCVV
WRITE(UNIT=KULOUT,FMT='(" Rd/Cpd (RKAPPA) = "
S ,e13.7)') RKAPPA
WRITE(UNIT=KULOUT,FMT='(" Rv/Rd-1 (RETV) = "
S ,e13.7)') RETV
WRITE(UNIT=KULOUT,FMT=9600)RKNTMS,RMSKNT
9600 FORMAT(/,6X,'RKNTMS (winds from M/S to Knots) : ',
S G12.6,/,6X,'RMSKNT (winds from Knots to M/S) : ',
S G12.6)
WRITE(UNIT=KULOUT,FMT=9610)RMBTPA,RPATMB
9610 FORMAT(/,6X,'RMBTMA (pressure from millibar to pascal) : ',
S G12.6,/,6X,'RPATMB (pressure from pascal to millibar) : ',
S G12.6)
C
C 7. Definition of constants used in thermodynamics conversion
C . ----------------------------------------------
700 CONTINUE
WRITE(UNIT=KULOUT,FMT=9620)
9620 FORMAT(/,6X,'Initialize thermodynamics constants from physics ',
S /,6x,'and store in comdeck comphy.cdk ')
C
CALL INCTPHYV
C
rminhu = 2.5D-6
rmaxes = 30.D0
C 8. Constants associated with the machine accuracy
C . ----------------------------------------------
800 CONTINUE
NR8SIZ=QQQR8SZ()
#if defined (C910)
RINFINI = 1.D+35
RZERO = 1.D-35
RPRECIS = 1.D-6
#else
RINFINI = 1.D+75
RZERO = 1.D-79
RPRECIS = 1.D-12
#endif
RETURN
END