/[lmdze]/trunk/libf/phylmd/Radlwsw/swu.f
ViewVC logotype

Contents of /trunk/libf/phylmd/Radlwsw/swu.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 71 - (show annotations)
Mon Jul 8 18:12:18 2013 UTC (10 years, 9 months ago) by guez
File size: 5507 byte(s) 
No reason to call inidissip in ce0l.

In inidissip, set random seed to 1 beacuse PGI compiler does not
accept all zeros.

dq was computed needlessly in caladvtrac. Arguments masse and dq of
calfis not used.

Replaced real*8 by double precision.

Pass arrays with inverted order of vertical levels to conflx instead
of creating local variables for this inside conflx.
1 c
2 cIM ctes ds clesphys.h SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
3 SUBROUTINE SWU (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
4 S PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
5 S PRMU,PSEC,PUD)
6 use dimens_m
7 use dimphy
8 use clesphys
9 use SUPHEC_M
10 use raddim
11 use radepsi
12 use radopt
13 IMPLICIT none
14 C
15 C* ARGUMENTS:
16 C
17 DOUBLE PRECISION PSCT
18 cIM ctes ds clesphys.h DOUBLE PRECISION RCO2
19 DOUBLE PRECISION PCLDSW(KDLON,KFLEV)
20 DOUBLE PRECISION PPMB(KDLON,KFLEV+1)
21 DOUBLE PRECISION PPSOL(KDLON)
22 DOUBLE PRECISION PRMU0(KDLON)
23 DOUBLE PRECISION PFRAC(KDLON)
24 DOUBLE PRECISION PTAVE(KDLON,KFLEV)
25 DOUBLE PRECISION PWV(KDLON,KFLEV)
26 C
27 DOUBLE PRECISION PAKI(KDLON,2)
28 DOUBLE PRECISION PCLD(KDLON,KFLEV)
29 DOUBLE PRECISION PCLEAR(KDLON)
30 DOUBLE PRECISION PDSIG(KDLON,KFLEV)
31 DOUBLE PRECISION PFACT(KDLON)
32 DOUBLE PRECISION PRMU(KDLON)
33 DOUBLE PRECISION PSEC(KDLON)
34 DOUBLE PRECISION PUD(KDLON,5,KFLEV+1)
35 C
36 C* LOCAL VARIABLES:
37 C
38 INTEGER IIND(2)
39 DOUBLE PRECISION ZC1J(KDLON,KFLEV+1)
40 DOUBLE PRECISION ZCLEAR(KDLON)
41 DOUBLE PRECISION ZCLOUD(KDLON)
42 DOUBLE PRECISION ZN175(KDLON)
43 DOUBLE PRECISION ZN190(KDLON)
44 DOUBLE PRECISION ZO175(KDLON)
45 DOUBLE PRECISION ZO190(KDLON)
46 DOUBLE PRECISION ZSIGN(KDLON)
47 DOUBLE PRECISION ZR(KDLON,2)
48 DOUBLE PRECISION ZSIGO(KDLON)
49 DOUBLE PRECISION ZUD(KDLON,2)
50 DOUBLE PRECISION ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
51 INTEGER jl, jk, jkp1, jkl, jklp1, ja
52 C
53 C* Prescribed Data:
54 c
55 DOUBLE PRECISION ZPDH2O,ZPDUMG
56 SAVE ZPDH2O,ZPDUMG
57 DOUBLE PRECISION ZPRH2O,ZPRUMG
58 SAVE ZPRH2O,ZPRUMG
59 DOUBLE PRECISION RTDH2O,RTDUMG
60 SAVE RTDH2O,RTDUMG
61 DOUBLE PRECISION RTH2O ,RTUMG
62 SAVE RTH2O ,RTUMG
63 DATA ZPDH2O,ZPDUMG / 0.8 , 0.75 /
64 DATA ZPRH2O,ZPRUMG / 30000., 30000. /
65 DATA RTDH2O,RTDUMG / 0.40 , 0.375 /
66 DATA RTH2O ,RTUMG / 240. , 240. /
67 C ------------------------------------------------------------------
68 C
69 C* 1. COMPUTES AMOUNTS OF ABSORBERS
70 C -----------------------------
71 C
72 100 CONTINUE
73 C
74 IIND(1)=1
75 IIND(2)=2
76 C
77 C
78 C* 1.1 INITIALIZES QUANTITIES
79 C ----------------------
80 C
81 110 CONTINUE
82 C
83 DO 111 JL = 1, KDLON
84 PUD(JL,1,KFLEV+1)=0.
85 PUD(JL,2,KFLEV+1)=0.
86 PUD(JL,3,KFLEV+1)=0.
87 PUD(JL,4,KFLEV+1)=0.
88 PUD(JL,5,KFLEV+1)=0.
89 PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
90 PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
91 PSEC(JL)=1./PRMU(JL)
92 ZC1J(JL,KFLEV+1)=0.
93 111 CONTINUE
94 C
95 C* 1.3 AMOUNTS OF ABSORBERS
96 C --------------------
97 C
98 130 CONTINUE
99 C
100 DO 131 JL= 1, KDLON
101 ZUD(JL,1) = 0.
102 ZUD(JL,2) = 0.
103 ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
104 ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
105 ZSIGO(JL) = PPSOL(JL)
106 ZCLEAR(JL)=1.
107 ZCLOUD(JL)=0.
108 131 CONTINUE
109 C
110 DO 133 JK = 1 , KFLEV
111 JKP1 = JK + 1
112 JKL = KFLEV+1 - JK
113 JKLP1 = JKL+1
114 DO 132 JL = 1, KDLON
115 ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
116 ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
117 ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
118 ZSIGN(JL) = 100. * PPMB(JL,JKP1)
119 PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
120 ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
121 ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
122 ZDSCO2 = ZO175(JL) - ZN175(JL)
123 ZDSH2O = ZO190(JL) - ZN190(JL)
124 PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
125 . * ZDSH2O * ZWH2O * ZRTH
126 PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
127 . * ZDSCO2 * RCO2 * ZRTU
128 ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
129 PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
130 PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
131 ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
132 ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
133 ZSIGO(JL) = ZSIGN(JL)
134 ZO175(JL) = ZN175(JL)
135 ZO190(JL) = ZN190(JL)
136 C
137 IF (NOVLP.EQ.1) THEN
138 ZCLEAR(JL)=ZCLEAR(JL)
139 S *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
140 S /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
141 ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
142 ZCLOUD(JL) = PCLDSW(JL,JKL)
143 ELSE IF (NOVLP.EQ.2) THEN
144 ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
145 ZC1J(JL,JKL) = ZCLOUD(JL)
146 ELSE IF (NOVLP.EQ.3) THEN
147 ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
148 ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
149 ZC1J(JL,JKL) = ZCLOUD(JL)
150 END IF
151 132 CONTINUE
152 133 CONTINUE
153 DO 134 JL=1, KDLON
154 PCLEAR(JL)=1.-ZC1J(JL,1)
155 134 CONTINUE
156 DO 136 JK=1,KFLEV
157 DO 135 JL=1, KDLON
158 IF (PCLEAR(JL).LT.1.) THEN
159 PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
160 ELSE
161 PCLD(JL,JK)=0.
162 END IF
163 135 CONTINUE
164 136 CONTINUE
165 C
166 C
167 C* 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
168 C -----------------------------------------------
169 C
170 140 CONTINUE
171 C
172 DO 142 JA = 1,2
173 DO 141 JL = 1, KDLON
174 ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
175 141 CONTINUE
176 142 CONTINUE
177 C
178 CALL SWTT1(2, 2, IIND, ZUD, ZR)
179 C
180 DO 144 JA = 1,2
181 DO 143 JL = 1, KDLON
182 PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
183 143 CONTINUE
184 144 CONTINUE
185 C
186 C
187 C ------------------------------------------------------------------
188 C
189 RETURN
190 END
  ViewVC Help
Powered by ViewVC 1.1.21