/[lmdze]/trunk/libf/phylmd/Radlwsw/lwu.f90
ViewVC logotype

Annotation of /trunk/libf/phylmd/Radlwsw/lwu.f90

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (hide annotations)
Mon Jul 8 18:12:18 2013 UTC (10 years, 10 months ago) by guez
File size: 12993 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 guez 71 module LWU_m
2    
3     IMPLICIT none
4    
5     contains
6    
7     SUBROUTINE LWU(PAER, PDP, PPMB, PPSOL, POZ, PTAVE, PVIEW, PWV, PABCU)
8    
9     ! Purpose. Computes absorber amounts including pressure and
10     ! temperature effects.
11    
12     ! Method. Computes the pressure and temperature weighted amounts
13     ! of absorbers.
14    
15     ! Reference. See radiation's part of the model's documentation and
16     ! ECMWF research department documentation of the IFS.
17    
18     ! Author. Jean-Jacques Morcrette, ECMWF.
19    
20     ! Modifications.
21     ! Original : 89-07-14
22     ! Voigt lines (loop 404 modified) - JJM & PhD - 01/96
23    
24     USE clesphys, ONLY: rcfc11, rcfc12, rch4, rco2, rn2o
25     USE suphec_m, ONLY: rg
26     USE raddim, ONLY: kdlon, kflev
27     USE radepsi, ONLY: zepsco, zepscq
28     USE radopt, ONLY: levoigt
29     USE raddimlw, ONLY: ng1, ng1p1, ninter, nua
30    
31     ! ARGUMENTS:
32    
33     DOUBLE PRECISION PAER(KDLON, KFLEV, 5)
34     DOUBLE PRECISION PDP(KDLON, KFLEV)
35     DOUBLE PRECISION PPMB(KDLON, KFLEV + 1)
36     DOUBLE PRECISION PPSOL(KDLON)
37     DOUBLE PRECISION POZ(KDLON, KFLEV)
38     DOUBLE PRECISION PTAVE(KDLON, KFLEV)
39     DOUBLE PRECISION PVIEW(KDLON)
40     DOUBLE PRECISION PWV(KDLON, KFLEV)
41    
42     DOUBLE PRECISION PABCU(KDLON, NUA, 3 * KFLEV + 1)
43     ! effective absorber amounts
44    
45     ! LOCAL VARIABLES:
46    
47     DOUBLE PRECISION ZABLY(KDLON, NUA, 3 * KFLEV + 1)
48     DOUBLE PRECISION ZDUC(KDLON, 3 * KFLEV + 1)
49     DOUBLE PRECISION ZPHIO(KDLON)
50     DOUBLE PRECISION ZPSC2(KDLON)
51     DOUBLE PRECISION ZPSC3(KDLON)
52     DOUBLE PRECISION ZPSH1(KDLON)
53     DOUBLE PRECISION ZPSH2(KDLON)
54     DOUBLE PRECISION ZPSH3(KDLON)
55     DOUBLE PRECISION ZPSH4(KDLON)
56     DOUBLE PRECISION ZPSH5(KDLON)
57     DOUBLE PRECISION ZPSH6(KDLON)
58     DOUBLE PRECISION ZPSIO(KDLON)
59     DOUBLE PRECISION ZTCON(KDLON)
60     DOUBLE PRECISION ZPHM6(KDLON)
61     DOUBLE PRECISION ZPSM6(KDLON)
62     DOUBLE PRECISION ZPHN6(KDLON)
63     DOUBLE PRECISION ZPSN6(KDLON)
64     DOUBLE PRECISION ZSSIG(KDLON, 3 * KFLEV + 1)
65     DOUBLE PRECISION ZTAVI(KDLON)
66     DOUBLE PRECISION ZUAER(KDLON, Ninter)
67     DOUBLE PRECISION ZXOZ(KDLON)
68     DOUBLE PRECISION ZXWV(KDLON)
69    
70     INTEGER jl, jk, jkj, jkjr, jkjp, ig1
71     INTEGER jki, jkip1, ja, jj
72     INTEGER jkl, jkp1, jkk, jkjpn
73     INTEGER jae1, jae2, jae3, jae, jjpn
74     INTEGER ir, jc, jcp1
75     DOUBLE PRECISION zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
76     DOUBLE PRECISION zfppw, ztx, ztx2, zzably
77     DOUBLE PRECISION zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
78     DOUBLE PRECISION zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
79     DOUBLE PRECISION zcac8, zcbc8
80     DOUBLE PRECISION zalup, zdiff
81    
82     DOUBLE PRECISION PVGCO2, PVGH2O, PVGO3
83    
84     DOUBLE PRECISION, PARAMETER:: R10E = 0.4342945
85     ! decimal / natural logarithm factor
86    
87     ! Used Data Block:
88    
89     DOUBLE PRECISION:: TREF = 250d0
90     DOUBLE PRECISION:: RT1(2) = (/ - 0.577350269d0, 0.577350269d0/)
91     DOUBLE PRECISION RAER(5, 5)
92     DOUBLE PRECISION AT(8, 3), BT(8, 3)
93     DOUBLE PRECISION:: OCT(4) = (/- 0.326D-3, - 0.102D-5, 0.137D-2, - 0.535D-5/)
94    
95     DATA RAER / .038520, .037196, .040532, .054934, .038520, &
96     .12613, .18313, .10357, .064106, .126130, &
97     .012579, .013649, .018652, .025181, .012579, &
98     .011890, .016142, .021105, .028908, .011890, &
99     .013792, .026810, .052203, .066338, .013792 /
100    
101     DATA (AT(1, IR), IR = 1, 3) / 0.298199E-02, - .394023E-03, 0.319566E-04 /
102     DATA (BT(1, IR), IR = 1, 3) / - 0.106432E-04, 0.660324E-06, 0.174356E-06 /
103     DATA (AT(2, IR), IR = 1, 3) / 0.143676E-01, 0.366501E-02, -.160822E-02 /
104     DATA (BT(2, IR), IR = 1, 3) / -0.553979E-04, - .101701E-04, 0.920868E-05 /
105     DATA (AT(3, IR), IR = 1, 3) / 0.197861E-01, 0.315541E-02, - .174547E-02 /
106     DATA (BT(3, IR), IR = 1, 3) / - 0.877012E-04, 0.513302E-04, 0.523138E-06 /
107     DATA (AT(4, IR), IR = 1, 3) / 0.289560E-01, - .208807E-02, - .121943E-02 /
108     DATA (BT(4, IR), IR = 1, 3) / - 0.165960E-03, 0.157704E-03, - .146427E-04 /
109     DATA (AT(5, IR), IR = 1, 3) / 0.103800E-01, 0.436296E-02, - .161431E-02 /
110     DATA (BT(5, IR), IR = 1, 3) / - .276744E-04, - .327381E-04, 0.127646E-04 /
111     DATA (AT(6, IR), IR = 1, 3) / 0.868859E-02, - .972752E-03, 0.000000E-00 /
112     DATA (BT(6, IR), IR = 1, 3) / - .278412E-04, - .713940E-06, 0.117469E-05 /
113     DATA (AT(7, IR), IR = 1, 3) / 0.250073E-03, 0.455875E-03, 0.109242E-03 /
114     DATA (BT(7, IR), IR = 1, 3) / 0.199846E-05, - .216313E-05, 0.175991E-06 /
115     DATA (AT(8, IR), IR = 1, 3) / 0.307423E-01, 0.110879E-02, - .322172E-03 /
116     DATA (BT(8, IR), IR = 1, 3) / - 0.108482E-03, 0.258096E-05, - .814575E-06 /
117    
118     !-----------------------------------------------------------------------
119    
120     IF (LEVOIGT) THEN
121     PVGCO2 = 60.
122     PVGH2O = 30.
123     PVGO3 = 400.
124     ELSE
125     PVGCO2 = 0.
126     PVGH2O = 0.
127     PVGO3 = 0.
128     ENDIF
129    
130     ! 2. PRESSURE OVER GAUSS SUB-LEVELS
131    
132     DO JL = 1, KDLON
133     ZSSIG(JL, 1) = PPMB(JL, 1) * 100.
134     end DO
135    
136     DO JK = 1, KFLEV
137     JKJ = (JK - 1) * NG1P1 + 1
138     JKJR = JKJ
139     JKJP = JKJ + NG1P1
140     DO JL = 1, KDLON
141     ZSSIG(JL, JKJP) = PPMB(JL, JK + 1) * 100.
142     end DO
143     DO IG1 = 1, NG1
144     JKJ = JKJ + 1
145     DO JL = 1, KDLON
146     ZSSIG(JL, JKJ) = (ZSSIG(JL, JKJR) + ZSSIG(JL, JKJP)) * 0.5 &
147     + RT1(IG1) * (ZSSIG(JL, JKJP) - ZSSIG(JL, JKJR)) * 0.5
148     end DO
149     end DO
150     end DO
151    
152     ! 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
153    
154     DO JKI = 1, 3 * KFLEV
155     JKIP1 = JKI + 1
156     DO JL = 1, KDLON
157     ZABLY(JL, 5, JKI) = (ZSSIG(JL, JKI) + ZSSIG(JL, JKIP1)) * 0.5
158     ZABLY(JL, 3, JKI) = (ZSSIG(JL, JKI) - ZSSIG(JL, JKIP1)) / (10. * RG)
159     end DO
160     end DO
161    
162     DO JK = 1, KFLEV
163     JKP1 = JK + 1
164     JKL = KFLEV + 1 - JK
165     DO JL = 1, KDLON
166     ZXWV(JL) = MAX(PWV(JL, JK), ZEPSCQ)
167     ZXOZ(JL) = MAX(POZ(JL, JK) / PDP(JL, JK), ZEPSCO)
168     end DO
169     JKJ = (JK - 1) * NG1P1 + 1
170     JKJPN = JKJ + NG1
171     DO JKK = JKJ, JKJPN
172     DO JL = 1, KDLON
173     ZDPM = ZABLY(JL, 3, JKK)
174     ZUPM = ZABLY(JL, 5, JKK) * ZDPM / 101325.
175     ZUPMCO2 = (ZABLY(JL, 5, JKK) + PVGCO2) * ZDPM / 101325.
176     ZUPMH2O = (ZABLY(JL, 5, JKK) + PVGH2O) * ZDPM / 101325.
177     ZUPMO3 = (ZABLY(JL, 5, JKK) + PVGO3) * ZDPM / 101325.
178     ZDUC(JL, JKK) = ZDPM
179     ZABLY(JL, 12, JKK) = ZXOZ(JL) * ZDPM
180     ZABLY(JL, 13, JKK) = ZXOZ(JL) * ZUPMO3
181     ZU6 = ZXWV(JL) * ZUPM
182     ZFPPW = 1.6078 * ZXWV(JL) / (1. + 0.608 * ZXWV(JL))
183     ZABLY(JL, 6, JKK) = ZXWV(JL) * ZUPMH2O
184     ZABLY(JL, 11, JKK) = ZU6 * ZFPPW
185     ZABLY(JL, 10, JKK) = ZU6 * (1. - ZFPPW)
186     ZABLY(JL, 9, JKK) = RCO2 * ZUPMCO2
187     ZABLY(JL, 8, JKK) = RCO2 * ZDPM
188     end DO
189     end DO
190     end DO
191    
192     ! 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
193    
194     DO JA = 1, NUA
195     DO JL = 1, KDLON
196     PABCU(JL, JA, 3 * KFLEV + 1) = 0.
197     end DO
198     end DO
199    
200     DO JK = 1, KFLEV
201     JJ = (JK - 1) * NG1P1 + 1
202     JJPN = JJ + NG1
203     JKL = KFLEV + 1 - JK
204    
205     ! 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
206    
207     JAE1 = 3 * KFLEV + 1 - JJ
208     JAE2 = 3 * KFLEV + 1 - (JJ + 1)
209     JAE3 = 3 * KFLEV + 1 - JJPN
210     DO JAE = 1, 5
211     DO JL = 1, KDLON
212     ZUAER(JL, JAE) = (RAER(JAE, 1) * PAER(JL, JKL, 1) &
213     + RAER(JAE, 2) * PAER(JL, JKL, 2) &
214     + RAER(JAE, 3) * PAER(JL, JKL, 3) &
215     + RAER(JAE, 4) * PAER(JL, JKL, 4) &
216     + RAER(JAE, 5) * PAER(JL, JKL, 5)) &
217     / (ZDUC(JL, JAE1) + ZDUC(JL, JAE2) + ZDUC(JL, JAE3))
218     end DO
219     end DO
220    
221     ! 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
222    
223     DO JL = 1, KDLON
224     ZTAVI(JL) = PTAVE(JL, JKL)
225     ZTCON(JL) = EXP(6.08 * (296. / ZTAVI(JL) - 1.))
226     ZTX = ZTAVI(JL) - TREF
227     ZTX2 = ZTX * ZTX
228     ZZABLY = ZABLY(JL, 6, JAE1) + ZABLY(JL, 6, JAE2) + ZABLY(JL, 6, JAE3)
229     ZUP = MIN(MAX(0.5 * R10E * LOG(ZZABLY) + 5., 0d0), 6d0)
230     ZCAH1 = AT(1, 1) + ZUP * (AT(1, 2) + ZUP * (AT(1, 3)))
231     ZCBH1 = BT(1, 1) + ZUP * (BT(1, 2) + ZUP * (BT(1, 3)))
232     ZPSH1(JL) = EXP(ZCAH1 * ZTX + ZCBH1 * ZTX2)
233     ZCAH2 = AT(2, 1) + ZUP * (AT(2, 2) + ZUP * (AT(2, 3)))
234     ZCBH2 = BT(2, 1) + ZUP * (BT(2, 2) + ZUP * (BT(2, 3)))
235     ZPSH2(JL) = EXP(ZCAH2 * ZTX + ZCBH2 * ZTX2)
236     ZCAH3 = AT(3, 1) + ZUP * (AT(3, 2) + ZUP * (AT(3, 3)))
237     ZCBH3 = BT(3, 1) + ZUP * (BT(3, 2) + ZUP * (BT(3, 3)))
238     ZPSH3(JL) = EXP(ZCAH3 * ZTX + ZCBH3 * ZTX2)
239     ZCAH4 = AT(4, 1) + ZUP * (AT(4, 2) + ZUP * (AT(4, 3)))
240     ZCBH4 = BT(4, 1) + ZUP * (BT(4, 2) + ZUP * (BT(4, 3)))
241     ZPSH4(JL) = EXP(ZCAH4 * ZTX + ZCBH4 * ZTX2)
242     ZCAH5 = AT(5, 1) + ZUP * (AT(5, 2) + ZUP * (AT(5, 3)))
243     ZCBH5 = BT(5, 1) + ZUP * (BT(5, 2) + ZUP * (BT(5, 3)))
244     ZPSH5(JL) = EXP(ZCAH5 * ZTX + ZCBH5 * ZTX2)
245     ZCAH6 = AT(6, 1) + ZUP * (AT(6, 2) + ZUP * (AT(6, 3)))
246     ZCBH6 = BT(6, 1) + ZUP * (BT(6, 2) + ZUP * (BT(6, 3)))
247     ZPSH6(JL) = EXP(ZCAH6 * ZTX + ZCBH6 * ZTX2)
248     ZPHM6(JL) = EXP(- 5.81E-4 * ZTX - 1.13E-6 * ZTX2)
249     ZPSM6(JL) = EXP(- 5.57E-4 * ZTX - 3.30E-6 * ZTX2)
250     ZPHN6(JL) = EXP(- 3.46E-5 * ZTX + 2.05E-7 * ZTX2)
251     ZPSN6(JL) = EXP(3.70E-3 * ZTX - 2.30E-6 * ZTX2)
252     end DO
253    
254     DO JL = 1, KDLON
255     ZTAVI(JL) = PTAVE(JL, JKL)
256     ZTX = ZTAVI(JL) - TREF
257     ZTX2 = ZTX * ZTX
258     ZZABLY = ZABLY(JL, 9, JAE1) + ZABLY(JL, 9, JAE2) + ZABLY(JL, 9, JAE3)
259     ZALUP = R10E * LOG(ZZABLY)
260     ZUP = MAX(0d0, 5.0 + 0.5 * ZALUP)
261     ZPSC2(JL) = (ZTAVI(JL) / TREF) ** ZUP
262     ZCAC8 = AT(8, 1) + ZUP * (AT(8, 2) + ZUP * (AT(8, 3)))
263     ZCBC8 = BT(8, 1) + ZUP * (BT(8, 2) + ZUP * (BT(8, 3)))
264     ZPSC3(JL) = EXP(ZCAC8 * ZTX + ZCBC8 * ZTX2)
265     ZPHIO(JL) = EXP(OCT(1) * ZTX + OCT(2) * ZTX2)
266     ZPSIO(JL) = EXP(2. * (OCT(3) * ZTX + OCT(4) * ZTX2))
267     end DO
268    
269     DO JKK = JJ, JJPN
270     JC = 3 * KFLEV + 1 - JKK
271     JCP1 = JC + 1
272     DO JL = 1, KDLON
273     ZDIFF = PVIEW(JL)
274     PABCU(JL, 10, JC) = PABCU(JL, 10, JCP1) &
275     + ZABLY(JL, 10, JC) * ZDIFF
276     PABCU(JL, 11, JC) = PABCU(JL, 11, JCP1) &
277     + ZABLY(JL, 11, JC) * ZTCON(JL) * ZDIFF
278    
279     PABCU(JL, 12, JC) = PABCU(JL, 12, JCP1) &
280     + ZABLY(JL, 12, JC) * ZPHIO(JL) * ZDIFF
281     PABCU(JL, 13, JC) = PABCU(JL, 13, JCP1) &
282     + ZABLY(JL, 13, JC) * ZPSIO(JL) * ZDIFF
283    
284     PABCU(JL, 7, JC) = PABCU(JL, 7, JCP1) &
285     + ZABLY(JL, 9, JC) * ZPSC2(JL) * ZDIFF
286     PABCU(JL, 8, JC) = PABCU(JL, 8, JCP1) &
287     + ZABLY(JL, 9, JC) * ZPSC3(JL) * ZDIFF
288     PABCU(JL, 9, JC) = PABCU(JL, 9, JCP1) &
289     + ZABLY(JL, 9, JC) * ZPSC3(JL) * ZDIFF
290    
291     PABCU(JL, 1, JC) = PABCU(JL, 1, JCP1) &
292     + ZABLY(JL, 6, JC) * ZPSH1(JL) * ZDIFF
293     PABCU(JL, 2, JC) = PABCU(JL, 2, JCP1) &
294     + ZABLY(JL, 6, JC) * ZPSH2(JL) * ZDIFF
295     PABCU(JL, 3, JC) = PABCU(JL, 3, JCP1) &
296     + ZABLY(JL, 6, JC) * ZPSH5(JL) * ZDIFF
297     PABCU(JL, 4, JC) = PABCU(JL, 4, JCP1) &
298     + ZABLY(JL, 6, JC) * ZPSH3(JL) * ZDIFF
299     PABCU(JL, 5, JC) = PABCU(JL, 5, JCP1) &
300     + ZABLY(JL, 6, JC) * ZPSH4(JL) * ZDIFF
301     PABCU(JL, 6, JC) = PABCU(JL, 6, JCP1) &
302     + ZABLY(JL, 6, JC) * ZPSH6(JL) * ZDIFF
303    
304     PABCU(JL, 14, JC) = PABCU(JL, 14, JCP1) &
305     + ZUAER(JL, 1) * ZDUC(JL, JC) * ZDIFF
306     PABCU(JL, 15, JC) = PABCU(JL, 15, JCP1) &
307     + ZUAER(JL, 2) * ZDUC(JL, JC) * ZDIFF
308     PABCU(JL, 16, JC) = PABCU(JL, 16, JCP1) &
309     + ZUAER(JL, 3) * ZDUC(JL, JC) * ZDIFF
310     PABCU(JL, 17, JC) = PABCU(JL, 17, JCP1) &
311     + ZUAER(JL, 4) * ZDUC(JL, JC) * ZDIFF
312     PABCU(JL, 18, JC) = PABCU(JL, 18, JCP1) &
313     + ZUAER(JL, 5) * ZDUC(JL, JC) * ZDIFF
314    
315     PABCU(JL, 19, JC) = PABCU(JL, 19, JCP1) &
316     + ZABLY(JL, 8, JC) * RCH4 / RCO2 * ZPHM6(JL) * ZDIFF
317     PABCU(JL, 20, JC) = PABCU(JL, 20, JCP1) &
318     + ZABLY(JL, 9, JC) * RCH4 / RCO2 * ZPSM6(JL) * ZDIFF
319     PABCU(JL, 21, JC) = PABCU(JL, 21, JCP1) &
320     + ZABLY(JL, 8, JC) * RN2O / RCO2 * ZPHN6(JL) * ZDIFF
321     PABCU(JL, 22, JC) = PABCU(JL, 22, JCP1) &
322     + ZABLY(JL, 9, JC) * RN2O / RCO2 * ZPSN6(JL) * ZDIFF
323    
324     PABCU(JL, 23, JC) = PABCU(JL, 23, JCP1) &
325     + ZABLY(JL, 8, JC) * RCFC11 / RCO2 * ZDIFF
326     PABCU(JL, 24, JC) = PABCU(JL, 24, JCP1) &
327     + ZABLY(JL, 8, JC) * RCFC12 / RCO2 * ZDIFF
328     end DO
329     end DO
330     end DO
331    
332     END SUBROUTINE LWU
333    
334     end module LWU_m

  ViewVC Help
Powered by ViewVC 1.1.21