source: LMDZ5/trunk/libf/phylmd/rrtm/sucst.F90 @ 5001

Last change on this file since 5001 was 2043, checked in by Laurent Fairhead, 10 years ago

Pour compilation avec ifort

For ifort compilation

  1. Baek
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 9.8 KB
RevLine 
[1989]1SUBROUTINE SUCST(KULOUT,KDAT,KSSS,KPRINTLEV)
2
3!**** *SUCST * - Routine to initialize the constants of the model.
4
5!     Purpose.
6!     --------
7!           Initialize and print the common YOMCST + initialize
8!         date and time of YOMRIP.
9
10!**   Interface.
11!     ----------
12!        *CALL* *SUCST (..)
13
14!        Explicit arguments :
15!        --------------------
16
17!        KULOUT  - logical unit for the output
18!        KDAT    - date in the form AAAAMMDD
19!        KSSS    - number of seconds in the day
20!        KPRINTLEV - printing level
21
22!        Implicit arguments :
23!        --------------------
24!        COMMON YOMCST
25!        COMMON YOMRIP
26
27!     Method.
28!     -------
29!        See documentation
30
31!     Externals.
32!     ----------
33
34!     Reference.
35!     ----------
36!        ECMWF Research Department documentation of the IFS
37
38!     Author.
39!     -------
40!        Mats Hamrud and Philippe Courtier  *ECMWF*
41
42!     Modifications.
43!     --------------
44!        Original : 87-10-15
45!        Additions : 90-07-30 (J.-F. Geleyn)
46!                    91-11-15 (M. Deque)
47!                    96-08-12 M.Hamrud - Reduce printing
48!        M.Hamrud      01-Oct-2003 CY28 Cleaning
49!     ------------------------------------------------------------------
50
51USE PARKIND1  ,ONLY : JPIM     ,JPRB
52USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
53
54USE YOMCST   , ONLY : RPI      ,RCLUM    ,RHPLA    ,RKBOL    ,&
55 & RNAVO    ,RDAY     ,REA      ,REPSM    ,RSIYEA   ,&
56 & RSIDAY   ,ROMEGA   ,RA       ,RG       ,R1SA     ,&
57 & RSIGMA   ,RI0      ,R        ,RMD      ,RMV      ,&
58 & RMO3     ,RD       ,RV       ,RCPD     ,RCPV     ,&
59 & RMCO2    ,RMCH4    ,RMN2O    ,RMCO     ,RMHCHO   ,&
60 & RMSO2    ,RMNO2    ,RMSF6    ,RMRA     ,&
61 & RCVD     ,RCVV     ,RKAPPA   ,RETV     ,RCW      ,&
62 & RCS      ,RLVTT    ,RLSTT    ,RLVZER   ,RLSZER   ,&
63 & RLMLT    ,RTT      ,RATM     ,RDT      ,RESTT    ,&
64 & RALPW    ,RBETW    ,RGAMW    ,RALPS    ,RBETS    ,&
65 & RGAMS    ,RALPD    ,RBETD    ,RGAMD 
66USE YOMRIP   , ONLY : RTIMST   ,RTIMTR
67
68IMPLICIT NONE
69
70INTEGER(KIND=JPIM),INTENT(IN)    :: KULOUT
71INTEGER(KIND=JPIM),INTENT(IN)    :: KDAT
72INTEGER(KIND=JPIM),INTENT(IN)    :: KSSS
73INTEGER(KIND=JPIM),INTENT(IN)    :: KPRINTLEV
74INTEGER(KIND=JPIM) :: IA, ID, IDAT, IM, ISSS, J
75
76REAL(KIND=JPRB) :: ZDE, ZET, ZJU, ZRS, ZRSREL, ZTETA, ZTI
77REAL(KIND=JPRB) :: ZHOOK_HANDLE
78
79#include "fctast.h"
80#include "fcttrm.h"
81#include "fcttim.h"
82!      -----------------------------------------------------------------
83
84!*       1.    DEFINE FUNDAMENTAL CONSTANTS.
85!              -----------------------------
86
87print*,'DANS SUCST CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
88IF (LHOOK) CALL DR_HOOK('SUCST',0,ZHOOK_HANDLE)
89RPI=2.0_JPRB*ASIN(1.0_JPRB)
90RCLUM=299792458._JPRB
91RHPLA=6.6260755E-34_JPRB
92RKBOL=1.380658E-23_JPRB
93RNAVO=6.0221367E+23_JPRB
94
95!     ------------------------------------------------------------------
96
97!*       2.    DEFINE ASTRONOMICAL CONSTANTS.
98!              ------------------------------
99
100RDAY=86400._JPRB
101REA=149597870000._JPRB
102REPSM=0.409093_JPRB
103
104RSIYEA=365.25_JPRB*RDAY*2.0_JPRB*RPI/6.283076_JPRB
105RSIDAY=RDAY/(1.0_JPRB+RDAY/RSIYEA)
106ROMEGA=2.0_JPRB*RPI/RSIDAY
107
108IDAT=KDAT
109ISSS=KSSS
110ID=NDD(IDAT)
111IM=NMM(IDAT)
112IA=NCCAA(IDAT)
113ZJU=RJUDAT(IA,IM,ID)
114ZTI=RTIME(IA,IM,ID,ISSS)
115RTIMST=ZTI
116RTIMTR=ZTI
117ZTETA=RTETA(ZTI)
118ZRS=RRS(ZTETA)
119ZDE=RDS(ZTETA)
120ZET=RET(ZTETA)
121ZRSREL=ZRS/REA
122
123!     ------------------------------------------------------------------
124
125!*       3.    DEFINE GEOIDE.
126!              --------------
127
128RG=9.80665_JPRB
129RA=6371229._JPRB
130R1SA=REAL(1.0_JPRB/REAL(RA,KIND(1.0_JPRB)),KIND(R1SA))
131
132!     ------------------------------------------------------------------
133
134!*       4.    DEFINE RADIATION CONSTANTS.
135!              ---------------------------
136
137RSIGMA=2.0_JPRB * RPI**5 * RKBOL**4 /(15._JPRB* RCLUM**2 * RHPLA**3)
138RI0=1370._JPRB
139
140!     ------------------------------------------------------------------
141
142!*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
143!              ------------------------------------------
144
145R=RNAVO*RKBOL
146RMD=28.9644_JPRB
147RMV=18.0153_JPRB
148RMO3=47.9942_JPRB
149RD=1000._JPRB*R/RMD
150RV=1000._JPRB*R/RMV
151RCPD=3.5_JPRB*RD
152RCVD=RCPD-RD
153RCPV=4._JPRB *RV
154RCVV=RCPV-RV
155RKAPPA=RD/RCPD
156RETV=RV/RD-1.0_JPRB
157RMCO2=44.0095_JPRB
158RMCH4=16.04_JPRB
159RMN2O=44.013_JPRB
160RMSF6=146.05_JPRB
161RMRA=222._JPRB
162RMCO=28.01_JPRB
163RMHCHO=30.03_JPRB
164RMNO2=46.01_JPRB
165RMSO2=64.07_JPRB
166
167!     ------------------------------------------------------------------
168
169!*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
170!              ---------------------------------------------
171
172RCW=4218._JPRB
173
174!     ------------------------------------------------------------------
175
176!*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
177!              --------------------------------------------
178
179RCS=2106._JPRB
180
181!     ------------------------------------------------------------------
182
183!*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
184!              ----------------------------------------------------
185
186RTT=273.16_JPRB
187RDT=11.82_JPRB
188RLVTT=2.5008E+6_JPRB
189RLSTT=2.8345E+6_JPRB
190RLVZER=RLVTT+RTT*(RCW-RCPV)
191RLSZER=RLSTT+RTT*(RCS-RCPV)
192RLMLT=RLSTT-RLVTT
193RATM=100000._JPRB
194
195!     ------------------------------------------------------------------
196
197!*       9.    SATURATED VAPOUR PRESSURE.
198!              --------------------------
199
200RESTT=611.14_JPRB
201RGAMW=(RCW-RCPV)/RV
202RBETW=RLVTT/RV+RGAMW*RTT
203RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT)
204print *,'SUCST: RESTT,RBETW,RTT,RGAMW',RESTT,RBETW,RTT,RGAMW
205print *,'SUCST: RALPW',RALPW
206RGAMS=(RCS-RCPV)/RV
207RBETS=RLSTT/RV+RGAMS*RTT
208RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT)
209print *,'SUCST: RESTT,RBETS,RTT,RGAMS',RESTT,RBETS,RTT,RGAMS
210print *,'SUCST: RALPS',RALPS
211RGAMS=(RCS-RCPV)/RV
212RGAMD=RGAMS-RGAMW
213RBETD=RBETS-RBETW
214RALPD=RALPS-RALPW
215
216!     ------------------------------------------------------------------
217
218!*      10.    PRINTS
219
220print*,'KPRINTLEV ',KPRINTLEV
221print*,'KULOUT ',KULOUT
222
223IF (KPRINTLEV >= 1) THEN
224  WRITE(KULOUT,'(''0*** Constants of the ICM   ***'')')
225  WRITE(KULOUT,'('' *** Fundamental constants ***'')')
226  WRITE(KULOUT,'(''           PI = '',E13.7,'' -'')')RPI
227  WRITE(KULOUT,'(''            c = '',E13.7,''m s-1'')')RCLUM
228  WRITE(KULOUT,'(''            h = '',E13.7,''J s'')')RHPLA
229  WRITE(KULOUT,'(''            K = '',E13.7,''J K-1'')')RKBOL
230  WRITE(KULOUT,'(''            N = '',E13.7,''mol-1'')')RNAVO
231  WRITE(KULOUT,'('' *** Astronomical constants ***'')')
232  WRITE(KULOUT,'(''          day = '',E13.7,'' s'')')RDAY
233  WRITE(KULOUT,'('' half g. axis = '',E13.7,'' m'')')REA
234  WRITE(KULOUT,'('' mean anomaly = '',E13.7,'' -'')')REPSM
235  WRITE(KULOUT,'('' sideral year = '',E13.7,'' s'')')RSIYEA
236  WRITE(KULOUT,'(''  sideral day = '',E13.7,'' s'')')RSIDAY
237  WRITE(KULOUT,'(''        omega = '',E13.7,'' s-1'')')ROMEGA
238
239  WRITE(KULOUT,'('' The initial date of the run is :'')')
240  WRITE(KULOUT,'(1X,I8,1X,I5,5X,I4,1X,I2,1X,I2)')IDAT,ISSS,IA,IM,ID
241  WRITE(KULOUT,'('' The Julian date is : '',F11.2)') ZJU
242  WRITE(KULOUT,'('' Time of the model  : '',F15.2,'' s'')')ZTI
243  WRITE(KULOUT,'('' Distance Earth-Sun : '',E13.7,'' m'')')ZRS
244  WRITE(KULOUT,'('' Relative Dist. E-S : '',E13.7,'' m'')')ZRSREL
245  WRITE(KULOUT,'('' Declination        : '',F12.5)') ZDE
246  WRITE(KULOUT,'('' Eq. of time        : '',F12.5,'' s'')')ZET
247  WRITE(KULOUT,'('' ***         Geoide         ***'')')
248  WRITE(KULOUT,'(''      Gravity = '',E13.7,'' m s-2'')')RG
249  WRITE(KULOUT,'('' Earth radius = '',E13.7,'' m'')')RA
250  WRITE(KULOUT,'('' Inverse E.R. = '',E13.7,'' m'')')R1SA
251  WRITE(KULOUT,'('' ***        Radiation       ***'')')
252  WRITE(KULOUT,'('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4'')')  RSIGMA
253  WRITE(KULOUT,'('' Solar const. = '',E13.7,'' W m-2'')')RI0
254  WRITE(KULOUT,'('' *** Thermodynamic, gas     ***'')')
255  WRITE(KULOUT,'('' Perfect gas  = '',e13.7)') R
256  WRITE(KULOUT,'('' Dry air mass = '',e13.7)') RMD
257  WRITE(KULOUT,'('' Vapour  mass = '',e13.7)') RMV
258  WRITE(KULOUT,'('' Ozone   mass = '',e13.7)') RMO3
259  WRITE(KULOUT,'('' Dry air cst. = '',e13.7)') RD
260  WRITE(KULOUT,'('' Vapour  cst. = '',e13.7)') RV
261  WRITE(KULOUT,'(''         Cpd  = '',e13.7)') RCPD
262  WRITE(KULOUT,'(''         Cvd  = '',e13.7)') RCVD
263  WRITE(KULOUT,'(''         Cpv  = '',e13.7)') RCPV
264  WRITE(KULOUT,'(''         Cvv  = '',e13.7)') RCVV
265  WRITE(KULOUT,'(''      Rd/Cpd  = '',e13.7)') RKAPPA
266  WRITE(KULOUT,'(''     Rv/Rd-1  = '',e13.7)') RETV
267  WRITE(KULOUT,'('' *** Thermodynamic, liquid  ***'')')
268  WRITE(KULOUT,'(''         Cw   = '',E13.7)') RCW
269  WRITE(KULOUT,'('' *** thermodynamic, solid   ***'')')
270  WRITE(KULOUT,'(''         Cs   = '',E13.7)') RCS
271  WRITE(KULOUT,'('' *** Thermodynamic, trans.  ***'')')
272  WRITE(KULOUT,'('' Fusion point  = '',E13.7)') RTT
273  WRITE(KULOUT,'('' RTT-Tx(ew-ei) = '',E13.7)') RDT
274  WRITE(KULOUT,'(''        RLvTt  = '',E13.7)') RLVTT
275  WRITE(KULOUT,'(''        RLsTt  = '',E13.7)') RLSTT
276  WRITE(KULOUT,'(''        RLv0   = '',E13.7)') RLVZER
277  WRITE(KULOUT,'(''        RLs0   = '',E13.7)') RLSZER
278  WRITE(KULOUT,'(''        RLMlt  = '',E13.7)') RLMLT
279  WRITE(KULOUT,'('' Normal press. = '',E13.7)') RATM
280  WRITE(KULOUT,'('' Latent heat :  '')')
281  WRITE(KULOUT,'(10(1X,E10.4))') (10._JPRB*J,J=-4,4)
282  WRITE(KULOUT,'(10(1X,E10.4))') (RLV(RTT+10._JPRB*J),J=-4,4)
283  WRITE(KULOUT,'(10(1X,E10.4))') (RLS(RTT+10._JPRB*J),J=-4,4)
284  WRITE(KULOUT,'('' *** Thermodynamic, satur.  ***'')')
285  WRITE(KULOUT,'('' Fusion point = '',E13.7)') RTT
286  WRITE(KULOUT,'(''      es(Tt)  = '',e13.7)') RESTT
287  WRITE(KULOUT,'('' es(T) :  '')')
288  WRITE(KULOUT,'(10(1X,E10.4))') (10._JPRB*J,J=-4,4)
289  WRITE(KULOUT,'(10(1X,E10.4))') (ESW(RTT+10._JPRB*J),J=-4,4)
290  WRITE(KULOUT,'(10(1X,E10.4))') (ESS(RTT+10._JPRB*J),J=-4,4)
[2043]291!  call flush(0)       !!!!! A REVOIR (MPL) les 7 lignes qui suivent
[1989]292   do j=1,9
293     print*,'TEST J',j
294     print*,'RTT...',RTT+10._JPRB*(J-5)
295     print*,'ES(RTT...',ES(RTT+10._JPRB*(J-5))
296   enddo
[2043]297  call flush(0)
[1989]298
299  WRITE(KULOUT,'(10(1X,E10.4))') (ES (RTT+10._JPRB*J),J=-4,4)
300ENDIF
301
302!     ------------------------------------------------------------------
303
304IF (LHOOK) CALL DR_HOOK('SUCST',1,ZHOOK_HANDLE)
305END SUBROUTINE SUCST
306
Note: See TracBrowser for help on using the repository browser.