/[lmdze]/trunk/Sources/phylmd/CV30_routines/cv30_yield.f
ViewVC logotype

Annotation of /trunk/Sources/phylmd/CV30_routines/cv30_yield.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 195 - (hide annotations)
Wed May 18 17:56:44 2016 UTC (8 years ago) by guez
File size: 19697 byte(s) 
In cv30_feed, iflag1 is 0 on entry so we can simplify the test for
iflag1 = 7.

In cv30_feed, for the computation of icb, replaced sequential search
(with a useless end of loop on k) by a call to locate.

In CV30 routines, replaced len, nloc, nd, na by klon or
klev. Philosophy: no more generality than actually necessary.

Converted as many variables as possible to named constants in
cv30_param_m and downgraded pbcrit, ptcrit, dtovsh, dpbase, dttrig,
tau, delta to local objects in procedures. spfac, betad and omtrain
are useless and removed.

Instead of filling the array sigp with the constant spfac in
cv30_undilute2, just made sigp a constant in cv30_unsat.

In cv_driver, define as allocatable variables that are only
used on the range (ncum, nl).
1 guez 185 module cv30_yield_m
2 guez 47
3 guez 97 implicit none
4 guez 47
5 guez 97 contains
6 guez 47
7 guez 188 SUBROUTINE cv30_yield(icb, inb, delt, t, rr, u, v, gz, p, ph, h, hp, lv, &
8     cpn, th, ep, clw, m, tp, mp, rp, up, vp, wt, water, evap, b, ment, &
9     qent, uent, vent, nent, elij, sig, tv, tvp, iflag, precip, VPrecip, &
10 guez 189 ft, fr, fu, fv, upwd, dnwd, dnwd0, ma, mike, tls, tps, qcondc)
11 guez 47
12 guez 195 ! Tendencies, precipitation, variables of interface with other
13     ! processes, etc.
14    
15 guez 187 use conema3_m, only: iflag_clw
16 guez 195 use cv30_param_m, only: minorig, nl, sigd
17 guez 190 use cv_thermo_m, only: cl, cpd, cpv, grav, rowl, rrd, rrv
18 guez 188 USE dimphy, ONLY: klev, klon
19 guez 187
20 guez 97 ! inputs:
21 guez 188 integer, intent(in):: icb(:), inb(:) ! (ncum)
22 guez 97 real, intent(in):: delt
23 guez 188 real t(klon, klev), rr(klon, klev), u(klon, klev), v(klon, klev)
24     real gz(klon, klev)
25     real p(klon, klev)
26     real ph(klon, klev + 1), h(klon, klev), hp(klon, klev)
27     real lv(klon, klev), cpn(klon, klev)
28     real th(klon, klev)
29     real ep(klon, klev), clw(klon, klev)
30     real m(klon, klev)
31     real tp(klon, klev)
32     real mp(klon, klev), rp(klon, klev), up(klon, klev)
33 guez 195 real, intent(in):: vp(:, 2:) ! (ncum, 2:nl)
34     real, intent(in):: wt(:, :) ! (ncum, nl - 1)
35 guez 189 real, intent(in):: water(:, :), evap(:, :) ! (ncum, nl)
36     real, intent(in):: b(:, :) ! (ncum, nl - 1)
37 guez 188 real ment(klon, klev, klev), qent(klon, klev, klev), uent(klon, klev, klev)
38     real vent(klon, klev, klev)
39     integer nent(klon, klev)
40     real elij(klon, klev, klev)
41     real sig(klon, klev)
42     real tv(klon, klev), tvp(klon, klev)
43 guez 47
44 guez 188 ! input / output:
45     integer iflag(klon)
46 guez 47
47 guez 97 ! outputs:
48 guez 188 real precip(klon)
49     real VPrecip(klon, klev + 1)
50     real ft(klon, klev), fr(klon, klev), fu(klon, klev), fv(klon, klev)
51     real upwd(klon, klev), dnwd(klon, klev)
52     real dnwd0(klon, klev)
53     real ma(klon, klev)
54     real mike(klon, klev)
55     real tls(klon, klev), tps(klon, klev)
56     real qcondc(klon, klev)
57 guez 97
58 guez 188 ! Local:
59 guez 195 real, parameter:: delta = 0.01 ! interface cloud parameterization
60 guez 188 integer ncum
61 guez 187 integer i, k, il, n, j, num1
62 guez 97 real rat, awat, delti
63 guez 105 real ax, bx, cx, dx
64 guez 97 real cpinv, rdcp, dpinv
65 guez 188 real lvcp(klon, klev)
66     real am(klon), work(klon), ad(klon), amp1(klon)
67     real up1(klon, klev, klev), dn1(klon, klev, klev)
68     real asum(klon), bsum(klon), csum(klon), dsum(klon)
69     real qcond(klon, klev), nqcond(klon, klev), wa(klon, klev)
70     real siga(klon, klev), sax(klon, klev), mac(klon, klev)
71 guez 47
72 guez 97 !-------------------------------------------------------------
73 guez 47
74 guez 188 ncum = size(icb)
75    
76 guez 97 ! initialization:
77 guez 47
78 guez 188 delti = 1.0 / delt
79 guez 47
80 guez 188 do il = 1, ncum
81     precip(il) = 0.0
82     VPrecip(il, klev + 1) = 0.
83 guez 97 enddo
84 guez 47
85 guez 188 do i = 1, klev
86     do il = 1, ncum
87     VPrecip(il, i) = 0.0
88     ft(il, i) = 0.0
89     fr(il, i) = 0.0
90     fu(il, i) = 0.0
91     fv(il, i) = 0.0
92     qcondc(il, i) = 0.0
93     qcond(il, i) = 0.0
94     nqcond(il, i) = 0.0
95 guez 47 enddo
96 guez 97 enddo
97 guez 47
98 guez 188 do i = 1, nl
99     do il = 1, ncum
100     lvcp(il, i) = lv(il, i) / cpn(il, i)
101 guez 47 enddo
102 guez 97 enddo
103 guez 47
104 guez 188 ! calculate surface precipitation in mm / day
105 guez 47
106 guez 188 do il = 1, ncum
107     if (ep(il, inb(il)) >= 1e-4) precip(il) = wt(il, 1) * sigd &
108     * water(il, 1) * 86400. * 1000. / (rowl * grav)
109 guez 97 enddo
110 guez 47
111 guez 188 ! CALCULATE VERTICAL PROFILE OF PRECIPITATIONs IN kg / m2 / s ===
112 guez 187
113 guez 97 ! MAF rajout pour lessivage
114 guez 188 do k = 1, nl - 1
115     do il = 1, ncum
116     if (k <= inb(il)) VPrecip(il, k) = wt(il, k) * sigd * water(il, k) &
117     / grav
118 guez 47 end do
119 guez 97 end do
120 guez 187
121 guez 188 ! calculate tendencies of lowest level potential temperature
122     ! and mixing ratio
123 guez 187
124 guez 188 do il = 1, ncum
125     work(il) = 1.0 / (ph(il, 1) - ph(il, 2))
126     am(il) = 0.0
127 guez 97 enddo
128 guez 47
129 guez 188 do k = 2, nl
130     do il = 1, ncum
131     if (k <= inb(il)) am(il) = am(il) + m(il, k)
132 guez 47 enddo
133 guez 97 enddo
134 guez 47
135 guez 188 do il = 1, ncum
136     ! Consist vect:
137     if (0.01 * grav * work(il) * am(il) >= delti) iflag(il) = 1
138 guez 47
139 guez 188 ft(il, 1) = 0.01 * grav * work(il) * am(il) * (t(il, 2) - t(il, 1) &
140     + (gz(il, 2) - gz(il, 1)) / cpn(il, 1))
141 guez 47
142 guez 188 ft(il, 1) = ft(il, 1) - 0.5 * lvcp(il, 1) * sigd * (evap(il, 1) &
143     + evap(il, 2))
144 guez 47
145 guez 188 ft(il, 1) = ft(il, 1) - 0.009 * grav * sigd * mp(il, 2) &
146     * t(il, 1) * b(il, 1) * work(il)
147 guez 47
148 guez 188 ft(il, 1) = ft(il, 1) + 0.01 * sigd * wt(il, 1) * (cl - cpd) &
149     * water(il, 2) * (t(il, 2) - t(il, 1)) * work(il) / cpn(il, 1)
150 guez 47
151 guez 187 !jyg1 Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
152     ! (sb: pour l'instant, on ne fait que le chgt concernant grav, pas evap)
153 guez 188 fr(il, 1) = 0.01 * grav * mp(il, 2) * (rp(il, 2) - rr(il, 1)) &
154     * work(il) + sigd * 0.5 * (evap(il, 1) + evap(il, 2))
155     ! + tard : + sigd * evap(il, 1)
156 guez 47
157 guez 188 fr(il, 1) = fr(il, 1) + 0.01 * grav * am(il) * (rr(il, 2) - rr(il, 1)) &
158     * work(il)
159 guez 47
160 guez 188 fu(il, 1) = fu(il, 1) + 0.01 * grav * work(il) * (mp(il, 2) &
161     * (up(il, 2) - u(il, 1)) + am(il) * (u(il, 2) - u(il, 1)))
162     fv(il, 1) = fv(il, 1) + 0.01 * grav * work(il) * (mp(il, 2) &
163     * (vp(il, 2) - v(il, 1)) + am(il) * (v(il, 2) - v(il, 1)))
164 guez 97 enddo ! il
165 guez 47
166 guez 188 do j = 2, nl
167     do il = 1, ncum
168 guez 187 if (j <= inb(il)) then
169 guez 188 fr(il, 1) = fr(il, 1) + 0.01 * grav * work(il) * ment(il, j, 1) &
170     * (qent(il, j, 1) - rr(il, 1))
171     fu(il, 1) = fu(il, 1) + 0.01 * grav * work(il) * ment(il, j, 1) &
172     * (uent(il, j, 1) - u(il, 1))
173     fv(il, 1) = fv(il, 1) + 0.01 * grav * work(il) * ment(il, j, 1) &
174     * (vent(il, j, 1) - v(il, 1))
175     endif
176 guez 47 enddo
177 guez 97 enddo
178 guez 47
179 guez 188 ! calculate tendencies of potential temperature and mixing ratio
180     ! at levels above the lowest level
181 guez 47
182 guez 188 ! first find the net saturated updraft and downdraft mass fluxes
183     ! through each level
184 guez 47
185 guez 188 loop_i: do i = 2, nl - 1
186     num1 = 0
187 guez 187
188 guez 188 do il = 1, ncum
189     if (i <= inb(il)) num1 = num1 + 1
190 guez 47 enddo
191    
192 guez 188 if (num1 > 0) then
193     amp1(:ncum) = 0.
194     ad(:ncum) = 0.
195 guez 47
196 guez 188 do k = i + 1, nl + 1
197     do il = 1, ncum
198     if (i <= inb(il) .and. k <= (inb(il) + 1)) then
199     amp1(il) = amp1(il) + m(il, k)
200     endif
201     end do
202 guez 97 end do
203 guez 47
204 guez 188 do k = 1, i
205     do j = i + 1, nl + 1
206     do il = 1, ncum
207     if (i <= inb(il) .and. j <= (inb(il) + 1)) then
208     amp1(il) = amp1(il) + ment(il, k, j)
209     endif
210     end do
211 guez 97 end do
212     end do
213 guez 47
214 guez 188 do k = 1, i - 1
215     do j = i, nl + 1 ! newvecto: nl au lieu nl + 1?
216     do il = 1, ncum
217     if (i <= inb(il) .and. j <= inb(il)) then
218     ad(il) = ad(il) + ment(il, j, k)
219     endif
220     end do
221 guez 97 end do
222     end do
223 guez 47
224 guez 188 do il = 1, ncum
225     if (i <= inb(il)) then
226     dpinv = 1.0 / (ph(il, i) - ph(il, i + 1))
227     cpinv = 1.0 / cpn(il, i)
228 guez 47
229 guez 188 ! Vecto:
230     if (0.01 * grav * dpinv * amp1(il) >= delti) iflag(il) = 1
231 guez 47
232 guez 188 ft(il, i) = 0.01 * grav * dpinv * (amp1(il) * (t(il, i + 1) &
233     - t(il, i) + (gz(il, i + 1) - gz(il, i)) * cpinv) &
234     - ad(il) * (t(il, i) - t(il, i - 1) + (gz(il, i) &
235     - gz(il, i - 1)) * cpinv)) - 0.5 * sigd * lvcp(il, i) &
236     * (evap(il, i) + evap(il, i + 1))
237     rat = cpn(il, i - 1) * cpinv
238     ft(il, i) = ft(il, i) - 0.009 * grav * sigd * (mp(il, i + 1) &
239     * t(il, i) * b(il, i) - mp(il, i) * t(il, i - 1) * rat &
240     * b(il, i - 1)) * dpinv
241     ft(il, i) = ft(il, i) + 0.01 * grav * dpinv * ment(il, i, i) &
242     * (hp(il, i) - h(il, i) + t(il, i) * (cpv - cpd) &
243     * (rr(il, i) - qent(il, i, i))) * cpinv
244 guez 47
245 guez 188 ft(il, i) = ft(il, i) + 0.01 * sigd * wt(il, i) * (cl - cpd) &
246     * water(il, i + 1) * (t(il, i + 1) - t(il, i)) * dpinv &
247     * cpinv
248 guez 47
249 guez 188 fr(il, i) = 0.01 * grav * dpinv * (amp1(il) * (rr(il, i + 1) &
250     - rr(il, i)) - ad(il) * (rr(il, i) - rr(il, i - 1)))
251     fu(il, i) = fu(il, i) + 0.01 * grav * dpinv * (amp1(il) &
252     * (u(il, i + 1) - u(il, i)) - ad(il) * (u(il, i) &
253     - u(il, i - 1)))
254     fv(il, i) = fv(il, i) + 0.01 * grav * dpinv * (amp1(il) &
255     * (v(il, i + 1) - v(il, i)) - ad(il) * (v(il, i) &
256     - v(il, i - 1)))
257     endif
258     end do
259 guez 47
260 guez 188 do k = 1, i - 1
261     do il = 1, ncum
262     if (i <= inb(il)) then
263     dpinv = 1.0 / (ph(il, i) - ph(il, i + 1))
264     cpinv = 1.0 / cpn(il, i)
265 guez 47
266 guez 188 awat = elij(il, k, i) - (1. - ep(il, i)) * clw(il, i)
267     awat = amax1(awat, 0.0)
268 guez 47
269 guez 188 fr(il, i) = fr(il, i) + 0.01 * grav * dpinv &
270     * ment(il, k, i) * (qent(il, k, i) - awat - rr(il, i))
271     fu(il, i) = fu(il, i) + 0.01 * grav * dpinv &
272     * ment(il, k, i) * (uent(il, k, i) - u(il, i))
273     fv(il, i) = fv(il, i) + 0.01 * grav * dpinv &
274     * ment(il, k, i) * (vent(il, k, i) - v(il, i))
275 guez 47
276 guez 188 ! (saturated updrafts resulting from mixing)
277     qcond(il, i) = qcond(il, i) + (elij(il, k, i) - awat)
278     nqcond(il, i) = nqcond(il, i) + 1.
279     endif ! i
280     end do
281 guez 97 end do
282 guez 47
283 guez 188 do k = i, nl + 1
284     do il = 1, ncum
285     if (i <= inb(il) .and. k <= inb(il)) then
286     dpinv = 1.0 / (ph(il, i) - ph(il, i + 1))
287     cpinv = 1.0 / cpn(il, i)
288 guez 47
289 guez 188 fr(il, i) = fr(il, i) + 0.01 * grav * dpinv &
290     * ment(il, k, i) * (qent(il, k, i) - rr(il, i))
291     fu(il, i) = fu(il, i) + 0.01 * grav * dpinv &
292     * ment(il, k, i) * (uent(il, k, i) - u(il, i))
293     fv(il, i) = fv(il, i) + 0.01 * grav * dpinv &
294     * ment(il, k, i) * (vent(il, k, i) - v(il, i))
295     endif
296     end do
297 guez 97 end do
298 guez 47
299 guez 188 do il = 1, ncum
300     if (i <= inb(il)) then
301     dpinv = 1.0 / (ph(il, i) - ph(il, i + 1))
302     cpinv = 1.0 / cpn(il, i)
303 guez 47
304 guez 188 ! sb: on ne fait pas encore la correction permettant de mieux
305     ! conserver l'eau:
306     fr(il, i) = fr(il, i) + 0.5 * sigd * (evap(il, i) &
307     + evap(il, i + 1)) + 0.01 * grav * (mp(il, i + 1) &
308     * (rp(il, i + 1) - rr(il, i)) - mp(il, i) * (rp(il, i) &
309     - rr(il, i - 1))) * dpinv
310 guez 47
311 guez 188 fu(il, i) = fu(il, i) + 0.01 * grav * (mp(il, i + 1) &
312     * (up(il, i + 1) - u(il, i)) - mp(il, i) * (up(il, i) &
313     - u(il, i - 1))) * dpinv
314     fv(il, i) = fv(il, i) + 0.01 * grav * (mp(il, i + 1) &
315     * (vp(il, i + 1) - v(il, i)) - mp(il, i) * (vp(il, i) &
316     - v(il, i - 1))) * dpinv
317     endif
318     end do
319 guez 47
320 guez 188 ! sb: interface with the cloud parameterization:
321 guez 47
322 guez 188 do k = i + 1, nl
323     do il = 1, ncum
324     if (k <= inb(il) .and. i <= inb(il)) then
325     ! (saturated downdrafts resulting from mixing)
326     qcond(il, i) = qcond(il, i) + elij(il, k, i)
327     nqcond(il, i) = nqcond(il, i) + 1.
328     endif
329     enddo
330     enddo
331 guez 47
332 guez 188 ! (particular case: no detraining level is found)
333     do il = 1, ncum
334     if (i <= inb(il) .and. nent(il, i) == 0) then
335     qcond(il, i) = qcond(il, i) + (1. - ep(il, i)) * clw(il, i)
336     nqcond(il, i) = nqcond(il, i) + 1.
337     endif
338     enddo
339 guez 47
340 guez 188 do il = 1, ncum
341     if (i <= inb(il) .and. nqcond(il, i) /= 0.) then
342     qcond(il, i) = qcond(il, i) / nqcond(il, i)
343     endif
344     enddo
345     end if
346     end do loop_i
347 guez 47
348 guez 188 ! move the detrainment at level inb down to level inb - 1
349     ! in such a way as to preserve the vertically
350     ! integrated enthalpy and water tendencies
351 guez 47
352 guez 188 do il = 1, ncum
353     ax = 0.1 * ment(il, inb(il), inb(il)) * (hp(il, inb(il)) &
354     - h(il, inb(il)) + t(il, inb(il)) * (cpv - cpd) &
355     * (rr(il, inb(il)) - qent(il, inb(il), inb(il)))) &
356     / (cpn(il, inb(il)) * (ph(il, inb(il)) - ph(il, inb(il) + 1)))
357     ft(il, inb(il)) = ft(il, inb(il)) - ax
358     ft(il, inb(il) - 1) = ft(il, inb(il) - 1) + ax * cpn(il, inb(il)) &
359     * (ph(il, inb(il)) - ph(il, inb(il) + 1)) / (cpn(il, inb(il) - 1) &
360     * (ph(il, inb(il) - 1) - ph(il, inb(il))))
361 guez 47
362 guez 188 bx = 0.1 * ment(il, inb(il), inb(il)) * (qent(il, inb(il), inb(il)) &
363     - rr(il, inb(il))) / (ph(il, inb(il)) - ph(il, inb(il) + 1))
364     fr(il, inb(il)) = fr(il, inb(il)) - bx
365     fr(il, inb(il) - 1) = fr(il, inb(il) - 1) &
366     + bx * (ph(il, inb(il)) - ph(il, inb(il) + 1)) &
367     / (ph(il, inb(il) - 1) - ph(il, inb(il)))
368 guez 47
369 guez 188 cx = 0.1 * ment(il, inb(il), inb(il)) * (uent(il, inb(il), inb(il)) &
370     - u(il, inb(il))) / (ph(il, inb(il)) - ph(il, inb(il) + 1))
371     fu(il, inb(il)) = fu(il, inb(il)) - cx
372     fu(il, inb(il) - 1) = fu(il, inb(il) - 1) &
373     + cx * (ph(il, inb(il)) - ph(il, inb(il) + 1)) &
374     / (ph(il, inb(il) - 1) - ph(il, inb(il)))
375 guez 47
376 guez 188 dx = 0.1 * ment(il, inb(il), inb(il)) * (vent(il, inb(il), inb(il)) &
377     - v(il, inb(il))) / (ph(il, inb(il)) - ph(il, inb(il) + 1))
378     fv(il, inb(il)) = fv(il, inb(il)) - dx
379     fv(il, inb(il) - 1) = fv(il, inb(il) - 1) &
380     + dx * (ph(il, inb(il)) - ph(il, inb(il) + 1)) &
381     / (ph(il, inb(il) - 1) - ph(il, inb(il)))
382 guez 47
383 guez 97 end do
384 guez 47
385 guez 188 ! homoginize tendencies below cloud base
386 guez 187
387 guez 188 do il = 1, ncum
388     asum(il) = 0.0
389     bsum(il) = 0.0
390     csum(il) = 0.0
391     dsum(il) = 0.0
392 guez 97 enddo
393 guez 47
394 guez 188 do i = 1, nl
395     do il = 1, ncum
396     if (i <= (icb(il) - 1)) then
397     asum(il) = asum(il) + ft(il, i) * (ph(il, i) - ph(il, i + 1))
398     bsum(il) = bsum(il) + fr(il, i) * (lv(il, i) + (cl - cpd) &
399     * (t(il, i) - t(il, 1))) * (ph(il, i) - ph(il, i + 1))
400     csum(il) = csum(il) + (lv(il, i) + (cl - cpd) * (t(il, i) &
401     - t(il, 1))) * (ph(il, i) - ph(il, i + 1))
402     dsum(il) = dsum(il) + t(il, i) * (ph(il, i) - ph(il, i + 1)) &
403     / th(il, i)
404 guez 97 endif
405 guez 47 enddo
406 guez 97 enddo
407 guez 47
408 guez 188 do i = 1, nl
409     do il = 1, ncum
410     if (i <= (icb(il) - 1)) then
411     ft(il, i) = asum(il) * t(il, i) / (th(il, i) * dsum(il))
412     fr(il, i) = bsum(il) / csum(il)
413 guez 97 endif
414 guez 47 enddo
415 guez 97 enddo
416 guez 47
417 guez 188 ! reset counter and return
418 guez 187
419 guez 188 do il = 1, ncum
420     sig(il, klev) = 2.0
421 guez 97 enddo
422 guez 47
423 guez 188 do i = 1, klev
424     do il = 1, ncum
425     upwd(il, i) = 0.0
426     dnwd(il, i) = 0.0
427 guez 47 enddo
428 guez 97 enddo
429 guez 47
430 guez 188 do i = 1, nl
431     do il = 1, ncum
432     dnwd0(il, i) = - mp(il, i)
433 guez 47 enddo
434 guez 97 enddo
435 guez 188 do i = nl + 1, klev
436     do il = 1, ncum
437     dnwd0(il, i) = 0.
438 guez 47 enddo
439 guez 97 enddo
440 guez 47
441 guez 188 do i = 1, nl
442     do il = 1, ncum
443 guez 187 if (i >= icb(il) .and. i <= inb(il)) then
444 guez 188 upwd(il, i) = 0.0
445     dnwd(il, i) = 0.0
446 guez 97 endif
447 guez 47 enddo
448 guez 97 enddo
449 guez 47
450 guez 188 do i = 1, nl
451     do k = 1, nl
452     do il = 1, ncum
453     up1(il, k, i) = 0.0
454     dn1(il, k, i) = 0.0
455 guez 97 enddo
456 guez 47 enddo
457 guez 97 enddo
458 guez 47
459 guez 188 do i = 1, nl
460     do k = i, nl
461     do n = 1, i - 1
462     do il = 1, ncum
463 guez 187 if (i >= icb(il).and.i <= inb(il).and.k <= inb(il)) then
464 guez 188 up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
465     dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
466 guez 97 endif
467     enddo
468     enddo
469 guez 47 enddo
470 guez 97 enddo
471 guez 47
472 guez 188 do i = 2, nl
473     do k = i, nl
474     do il = 1, ncum
475 guez 187 if (i <= inb(il).and.k <= inb(il)) then
476 guez 188 upwd(il, i) = upwd(il, i) + m(il, k) + up1(il, k, i)
477     dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
478 guez 97 endif
479     enddo
480 guez 47 enddo
481 guez 97 enddo
482 guez 47
483 guez 97 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
484 guez 187 ! determination de la variation de flux ascendant entre
485     ! deux niveau non dilue mike
486 guez 97 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
487 guez 47
488 guez 188 do i = 1, nl
489     do il = 1, ncum
490     mike(il, i) = m(il, i)
491 guez 47 enddo
492 guez 97 enddo
493 guez 47
494 guez 188 do i = nl + 1, klev
495     do il = 1, ncum
496     mike(il, i) = 0.
497 guez 47 enddo
498 guez 97 enddo
499 guez 47
500 guez 188 do i = 1, klev
501     do il = 1, ncum
502     ma(il, i) = 0
503 guez 47 enddo
504 guez 97 enddo
505 guez 47
506 guez 188 do i = 1, nl
507     do j = i, nl
508     do il = 1, ncum
509     ma(il, i) = ma(il, i) + m(il, j)
510 guez 97 enddo
511 guez 47 enddo
512 guez 97 enddo
513 guez 47
514 guez 188 do i = nl + 1, klev
515     do il = 1, ncum
516     ma(il, i) = 0.
517 guez 47 enddo
518 guez 97 enddo
519 guez 47
520 guez 188 do i = 1, nl
521     do il = 1, ncum
522     if (i <= (icb(il) - 1)) then
523     ma(il, i) = 0
524 guez 97 endif
525 guez 47 enddo
526 guez 97 enddo
527 guez 47
528 guez 97 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
529 guez 187 ! icb represente de niveau ou se trouve la
530     ! base du nuage, et inb le top du nuage
531 guez 97 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
532 guez 47
533 guez 188 do i = 1, klev
534     DO il = 1, ncum
535     rdcp = (rrd * (1. - rr(il, i)) - rr(il, i) * rrv) &
536     / (cpd * (1. - rr(il, i)) + rr(il, i) * cpv)
537     tls(il, i) = t(il, i) * (1000.0 / p(il, i))**rdcp
538     tps(il, i) = tp(il, i)
539 guez 97 end DO
540     enddo
541 guez 47
542 guez 188 ! diagnose the in-cloud mixing ratio
543     ! of condensed water
544     !
545 guez 47
546 guez 188 do i = 1, klev
547     do il = 1, ncum
548     mac(il, i) = 0.0
549     wa(il, i) = 0.0
550     siga(il, i) = 0.0
551     sax(il, i) = 0.0
552     enddo
553     enddo
554 guez 47
555 guez 188 do i = minorig, nl
556     do k = i + 1, nl + 1
557     do il = 1, ncum
558     if (i <= inb(il) .and. k <= (inb(il) + 1)) then
559     mac(il, i) = mac(il, i) + m(il, k)
560     endif
561     enddo
562     enddo
563     enddo
564 guez 47
565 guez 188 do i = 1, nl
566     do j = 1, i
567     do il = 1, ncum
568     if (i >= icb(il) .and. i <= (inb(il) - 1) &
569     .and. j >= icb(il)) then
570     sax(il, i) = sax(il, i) + rrd * (tvp(il, j) - tv(il, j)) &
571     * (ph(il, j) - ph(il, j + 1)) / p(il, j)
572     endif
573     enddo
574     enddo
575     enddo
576 guez 97
577 guez 188 do i = 1, nl
578     do il = 1, ncum
579     if (i >= icb(il) .and. i <= (inb(il) - 1) &
580     .and. sax(il, i) > 0.0) then
581     wa(il, i) = sqrt(2. * sax(il, i))
582     endif
583     enddo
584     enddo
585 guez 47
586 guez 188 do i = 1, nl
587     do il = 1, ncum
588     if (wa(il, i) > 0.0) siga(il, i) = mac(il, i) / wa(il, i) * rrd &
589     * tvp(il, i) / p(il, i) / 100. / delta
590     siga(il, i) = min(siga(il, i), 1.0)
591    
592 guez 187 if (iflag_clw == 0) then
593 guez 188 qcondc(il, i) = siga(il, i) * clw(il, i) * (1. - ep(il, i)) &
594     + (1. - siga(il, i)) * qcond(il, i)
595 guez 187 else if (iflag_clw == 1) then
596 guez 188 qcondc(il, i) = qcond(il, i)
597 guez 97 endif
598 guez 188 enddo
599     enddo
600 guez 47
601 guez 185 end SUBROUTINE cv30_yield
602 guez 97
603 guez 185 end module cv30_yield_m
  ViewVC Help
Powered by ViewVC 1.1.21