/[lmdze]/trunk/phylmd/CV3_routines/cv3_yield.f
ViewVC logotype

Annotation of /trunk/phylmd/CV3_routines/cv3_yield.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 97 - (hide annotations)
Fri Apr 25 14:58:31 2014 UTC (10 years, 1 month ago) by guez
File size: 24841 byte(s) 
Module pressure_var is now only used in gcm. Created local variables
pls and p3d in etat0, added argument p3d to regr_pr_o3.

In leapfrog, moved computation of p3d and exner function immediately
after integrd, for clarity (does not change the execution).

Removed unused arguments: ntra, tra1 and tra of cv3_compress; ntra,
tra and traent of cv3_mixing; ntra, ftra, ftra1 of cv3_uncompress;
ntra, tra, trap of cv3_unsat; ntra, tra, trap, traent, ftra of
cv3_yield; tra, tvp, pbase, bbase, dtvpdt1, dtvpdq1, dplcldt,
dplcldr, ntra of concvl; ndp1, ntra, tra1 of cv_driver

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