TETEN.inc
References to this file elsewhere.
1 SUBROUTINE TETEN(ICE)
2 C IMPLICIT DOUBLE PRECISION (A-H,O-Z,\)
3 REAL*8 XB,XC,X,TABLE,DTABLE
4 REAL*8 B,C,BI,CI,TSAT,TSATI
5 REAL*8 RTABLE !##
6 COMMON/CTETEN /TABLE (25000)
7 COMMON/DTETEN /DTABLE(25000)
8 COMMON/CLATENT/CTABLE(25000),DCL,TEMP0,TEMPI
9 COMMON/RLQIC /RTABLE(25000),TLI1,TLI2 !##
10 COMMON/COMPHC/ CP,HL,GASR,ER,G,STB,SOLCON,TWOMG
11 COMMON/COMEVP/CEV(4001),DFW,RDFW
12 DATA XB,XC/21.18123D0,5418.0D0/
13 DATA B,C,BI,CI,TSAT,TSATI/19.480254D0,4304.412D0,
14 & 23.684812D0,5803.3203D0,
15 & 29.55D0,7.85D0/
16 TEMP0 = t_kelvin
17 CBBK TEMPI = 233.15
18 TEMPI = 258.15
19 DTEMP = TEMP0-TEMPI
20 TLI1 = TEMPI !##
21 TLI2 = TEMP0 !##
22 IF(ICE.EQ.1) THEN
23 DICE = 3.33E5
24 ELSE
25 DICE = 0.0
26 ENDIF
27 HICE = HL + DICE
28 C DL/DT
29 DCL = -DICE/DTEMP
30 CX CLBYCP = HL/CP
31 CX CLBYCPI = HICE/CP
32 IF(ICE.EQ.0) THEN
33 DO 10 I = 1,25000
34 X = 123.2D0 + 0.01D0*I
35 ! WRFVAR compiles at double precision by default, so DEXP is overkill
36 ! TABLE(I) = 0.622*DEXP(B-C/(X-TSAT))
37 TABLE(I) = 0.622*EXP(B-C/(X-TSAT))
38 DTABLE(I) = TABLE(I)*C/(X-TSAT)**2
39 CTABLE(I) = HL
40 RTABLE(I) = 1. !##
41 10 CONTINUE
42 ELSE
43 DO 20 I = 1,25000
44 X = 123.2D0 + 0.01D0*I
45 IF(X.GE.TEMP0) THEN
46 ! TABLE(I) = 0.622*DEXP(B-C/(X-TSAT))
47 TABLE(I) = 0.622*EXP(B-C/(X-TSAT))
48 DTABLE(I) = TABLE(I)*C/(X-TSAT)**2
49 CTABLE(I) = HL
50 RTABLE(I) = 1. !##
51 ELSEIF(X.LE.TEMPI) THEN
52 ! TABLE(I) = 0.622*DEXP(BI-CI/(X-TSATI))
53 TABLE(I) = 0.622*EXP(BI-CI/(X-TSATI))
54 DTABLE(I) = TABLE(I)*CI/(X-TSATI)**2
55 CTABLE(I) = HICE
56 RTABLE(I) = 0. !##
57 ELSE
58 RR = (TEMP0-X)/DTEMP
59 CTABLE(I) = HL*(1.0-RR) + HICE*RR
60 ! TBL1 = 0.622*DEXP(B-C/(X-TSAT))
61 TBL1 = 0.622*EXP(B-C/(X-TSAT))
62 DTBL1 = TBL1*C/(X-TSAT)**2
63 ! TBL2 = 0.622*DEXP(BI-CI/(X-TSATI))
64 TBL2 = 0.622*EXP(BI-CI/(X-TSATI))
65 DTBL2 = TBL2*CI/(X-TSATI)**2
66 TABLE(I) = TBL1*(1.D0-RR)+TBL2*RR
67 DTABLE(I) = DTBL1*(1.D0-RR)+DTBL2*RR+(TBL1-TBL2)/DTEMP
68 RTABLE(I) = 1.D0-RR !##
69 C ## 3-JI KANSUU : RTABLE(I) = TT*TT*(3.-2.*TT)
70 C ## WHERE TT = 1.D0-RR
71 ENDIF
72 20 CONTINUE
73 ENDIF
74 FWMX = 5.0
75 FWMN = 0.0
76 IFWM = 4001
77 DFW = (FWMX-FWMN)/(IFWM-1.)
78 RDFW=1./DFW
79 *VOPTION NOFVAL
80 DO 30 I = 1,IFWM
81 FW = FWMN + DFW*(I-1.)
82 CEV(I) = 8.*GASR*(1.6+23.2*(FW)**0.167)*(FW)**0.467
83 30 CONTINUE
84 CEV(1) = 0.0
85 C ## CALL MNTRLQIC (RTABLE,TLI1,TLI2)
86 RETURN
87 END SUBROUTINE TETEN