/[lmdze]/trunk/libf/phylmd/phystokenc.f90
ViewVC logotype

Annotation of /trunk/libf/phylmd/phystokenc.f90

Parent Directory Parent Directory | Revision Log Revision Log


Revision 30 - (hide annotations)
Thu Apr 1 09:07:28 2010 UTC (14 years, 1 month ago) by guez
Original Path: trunk/libf/phylmd/phystokenc.f
File size: 12187 byte(s)
Imported Source files of the external library "IOIPSL_Lionel" into
"libf/IOIPSL".

Split "cray.f90" into "scopy.f90" and "ssum.f90".

Rewrote "leapfrog" in order to have a clearer algorithmic structure.

1 guez 3 !
2     ! $Header: /home/cvsroot/LMDZ4/libf/phylmd/phystokenc.F,v 1.2 2004/06/22 11:45:35 lmdzadmin Exp $
3     !
4     c
5     c
6     SUBROUTINE phystokenc (
7     I pdtphys,rlon,rlat,
8     I pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
9     I pfm_therm,pentr_therm,
10     I pcoefh,yu1,yv1,ftsol,pctsrf,
11     I frac_impa,frac_nucl,
12     I pphis,paire,dtime,itap)
13 guez 30 USE histwrite_m
14     use histcom
15 guez 3 use dimens_m
16     use indicesol
17     use dimphy
18     use conf_gcm_m
19     use tracstoke
20     IMPLICIT none
21    
22     c======================================================================
23     c Auteur(s) FH
24     c Objet: Moniteur general des tendances traceurs
25     c
26    
27     c======================================================================
28     c======================================================================
29    
30     c Arguments:
31     c
32     c EN ENTREE:
33     c ==========
34     c
35     c divers:
36     c -------
37     c
38 guez 12 real, intent(in):: pdtphys ! pas d'integration pour la physique (seconde)
39 guez 3 c
40 guez 7 integer physid
41     integer, intent(in):: itap
42 guez 3 save physid
43     integer ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)
44    
45     c convection:
46     c -----------
47     c
48     REAL pmfu(klon,klev) ! flux de masse dans le panache montant
49     REAL pmfd(klon,klev) ! flux de masse dans le panache descendant
50     REAL pen_u(klon,klev) ! flux entraine dans le panache montant
51     REAL pde_u(klon,klev) ! flux detraine dans le panache montant
52     REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
53     REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
54     real pt(klon,klev),t(klon,klev)
55     c
56     REAL, intent(in):: rlon(klon), rlat(klon)
57 guez 12 real, intent(in):: dtime
58 guez 3 REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
59    
60     c Couche limite:
61     c --------------
62     c
63     REAL pcoefh(klon,klev) ! coeff melange CL
64     REAL yv1(klon)
65     REAL yu1(klon),pphis(klon),paire(klon)
66    
67     c Les Thermiques : (Abderr 25 11 02)
68     c ---------------
69     REAL pfm_therm(klon,klev+1)
70     real fm_therm1(klon,klev)
71     REAL pentr_therm(klon,klev)
72     REAL entr_therm(klon,klev)
73     REAL fm_therm(klon,klev)
74     c
75     c Lessivage:
76     c ----------
77     c
78     REAL frac_impa(klon,klev)
79     REAL frac_nucl(klon,klev)
80     c
81     c Arguments necessaires pour les sources et puits de traceur
82     C
83     real ftsol(klon,nbsrf) ! Temperature du sol (surf)(Kelvin)
84     real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
85     c======================================================================
86     c
87     INTEGER i, k
88     c
89     REAL mfu(klon,klev) ! flux de masse dans le panache montant
90     REAL mfd(klon,klev) ! flux de masse dans le panache descendant
91     REAL en_u(klon,klev) ! flux entraine dans le panache montant
92     REAL de_u(klon,klev) ! flux detraine dans le panache montant
93     REAL en_d(klon,klev) ! flux entraine dans le panache descendant
94     REAL de_d(klon,klev) ! flux detraine dans le panache descendant
95     REAL coefh(klon,klev) ! flux detraine dans le panache descendant
96    
97     REAL pyu1(klon),pyv1(klon)
98     REAL pftsol(klon,nbsrf),ppsrf(klon,nbsrf)
99     real pftsol1(klon),pftsol2(klon),pftsol3(klon),pftsol4(klon)
100     real ppsrf1(klon),ppsrf2(klon),ppsrf3(klon),ppsrf4(klon)
101    
102     REAL dtcum
103    
104     integer iadvtr,irec
105     real zmin,zmax
106     logical ok_sync
107    
108     save t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum
109     save fm_therm,entr_therm
110     save iadvtr,irec
111     save pyu1,pyv1,pftsol,ppsrf
112    
113     data iadvtr,irec/0,1/
114     c
115     c Couche limite:
116     c======================================================================
117    
118     ok_sync = .true.
119     print*,'Dans phystokenc.F'
120     print*,'iadvtr= ',iadvtr
121     print*,'istphy= ',istphy
122     print*,'istdyn= ',istdyn
123    
124     IF (iadvtr.eq.0) THEN
125    
126     CALL initphysto('phystoke',
127     . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqmx,physid)
128    
129     write(*,*) 'apres initphysto ds phystokenc'
130    
131    
132     ENDIF
133     c
134     ndex2d = 0
135     ndex3d = 0
136     i=itap
137     CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
138 guez 15 CALL histwrite(physid,"phis",i,zx_tmp_2d)
139 guez 3 c
140     i=itap
141     CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
142 guez 15 CALL histwrite(physid,"aire",i,zx_tmp_2d)
143 guez 3
144     iadvtr=iadvtr+1
145     c
146     if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then
147     print*,'reinitialisation des champs cumules
148     s a iadvtr=',iadvtr
149     do k=1,klev
150     do i=1,klon
151     mfu(i,k)=0.
152     mfd(i,k)=0.
153     en_u(i,k)=0.
154     de_u(i,k)=0.
155     en_d(i,k)=0.
156     de_d(i,k)=0.
157     coefh(i,k)=0.
158     t(i,k)=0.
159     fm_therm(i,k)=0.
160     entr_therm(i,k)=0.
161     enddo
162     enddo
163     do i=1,klon
164     pyv1(i)=0.
165     pyu1(i)=0.
166     end do
167     do k=1,nbsrf
168     do i=1,klon
169     pftsol(i,k)=0.
170     ppsrf(i,k)=0.
171     enddo
172     enddo
173    
174     dtcum=0.
175     endif
176    
177     do k=1,klev
178     do i=1,klon
179     mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
180     mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
181     en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
182     de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
183     en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
184     de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
185     coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
186     t(i,k)=t(i,k)+pt(i,k)*pdtphys
187     fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
188     entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
189     enddo
190     enddo
191     do i=1,klon
192     pyv1(i)=pyv1(i)+yv1(i)*pdtphys
193     pyu1(i)=pyu1(i)+yu1(i)*pdtphys
194     end do
195     do k=1,nbsrf
196     do i=1,klon
197     pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
198     ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
199     enddo
200     enddo
201    
202     dtcum=dtcum+pdtphys
203    
204     IF(mod(iadvtr,istphy).eq.0) THEN
205     c
206     c normalisation par le temps cumule
207     do k=1,klev
208     do i=1,klon
209     mfu(i,k)=mfu(i,k)/dtcum
210     mfd(i,k)=mfd(i,k)/dtcum
211     en_u(i,k)=en_u(i,k)/dtcum
212     de_u(i,k)=de_u(i,k)/dtcum
213     en_d(i,k)=en_d(i,k)/dtcum
214     de_d(i,k)=de_d(i,k)/dtcum
215     coefh(i,k)=coefh(i,k)/dtcum
216     c Unitel a enlever
217     t(i,k)=t(i,k)/dtcum
218     fm_therm(i,k)=fm_therm(i,k)/dtcum
219     entr_therm(i,k)=entr_therm(i,k)/dtcum
220     enddo
221     enddo
222     do i=1,klon
223     pyv1(i)=pyv1(i)/dtcum
224     pyu1(i)=pyu1(i)/dtcum
225     end do
226     do k=1,nbsrf
227     do i=1,klon
228     pftsol(i,k)=pftsol(i,k)/dtcum
229     pftsol1(i) = pftsol(i,1)
230     pftsol2(i) = pftsol(i,2)
231     pftsol3(i) = pftsol(i,3)
232     pftsol4(i) = pftsol(i,4)
233    
234     ppsrf(i,k)=ppsrf(i,k)/dtcum
235     ppsrf1(i) = ppsrf(i,1)
236     ppsrf2(i) = ppsrf(i,2)
237     ppsrf3(i) = ppsrf(i,3)
238     ppsrf4(i) = ppsrf(i,4)
239    
240     enddo
241     enddo
242     c
243     c ecriture des champs
244     c
245     irec=irec+1
246    
247     ccccc
248     CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
249 guez 15 CALL histwrite(physid,"t",itap,zx_tmp_3d)
250 guez 3
251     CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
252 guez 15 CALL histwrite(physid,"mfu",itap,zx_tmp_3d)
253 guez 3 CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
254 guez 15 CALL histwrite(physid,"mfd",itap,zx_tmp_3d)
255 guez 3 CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
256 guez 15 CALL histwrite(physid,"en_u",itap,zx_tmp_3d)
257 guez 3 CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
258 guez 15 CALL histwrite(physid,"de_u",itap,zx_tmp_3d)
259 guez 3 CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
260 guez 15 CALL histwrite(physid,"en_d",itap,zx_tmp_3d)
261 guez 3 CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)
262 guez 15 CALL histwrite(physid,"de_d",itap,zx_tmp_3d)
263 guez 3 CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)
264 guez 15 CALL histwrite(physid,"coefh",itap,zx_tmp_3d)
265 guez 3
266     c ajou...
267     do k=1,klev
268     do i=1,klon
269     fm_therm1(i,k)=fm_therm(i,k)
270     enddo
271     enddo
272    
273     CALL gr_fi_ecrit(klev,klon,iim,jjm+1, fm_therm1, zx_tmp_3d)
274 guez 15 CALL histwrite(physid,"fm_th",itap,zx_tmp_3d)
275 guez 3 c
276     CALL gr_fi_ecrit(klev,klon,iim,jjm+1, entr_therm, zx_tmp_3d)
277 guez 15 CALL histwrite(physid,"en_th",itap,zx_tmp_3d)
278 guez 3 cccc
279     CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
280 guez 15 CALL histwrite(physid,"frac_impa",itap,zx_tmp_3d)
281 guez 3
282     CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
283 guez 15 CALL histwrite(physid,"frac_nucl",itap,zx_tmp_3d)
284 guez 3
285     CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
286 guez 15 CALL histwrite(physid,"pyu1",itap,zx_tmp_2d)
287 guez 3
288     CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
289 guez 15 CALL histwrite(physid,"pyv1",itap,zx_tmp_2d)
290 guez 3
291     CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
292 guez 15 CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d)
293 guez 3 CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
294 guez 15 CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d)
295 guez 3 CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
296 guez 15 CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d)
297 guez 3 CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
298 guez 15 CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d)
299 guez 3
300     CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
301 guez 15 CALL histwrite(physid,"psrf1",itap,zx_tmp_2d)
302 guez 3 CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
303 guez 15 CALL histwrite(physid,"psrf2",itap,zx_tmp_2d)
304 guez 3 CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
305 guez 15 CALL histwrite(physid,"psrf3",itap,zx_tmp_2d)
306 guez 3 CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
307 guez 15 CALL histwrite(physid,"psrf4",itap,zx_tmp_2d)
308 guez 3
309     if (ok_sync) call histsync(physid)
310     c if (ok_sync) call histsync
311    
312     c
313     cAA Test sur la valeur des coefficients de lessivage
314     c
315     zmin=1e33
316     zmax=-1e33
317     do k=1,klev
318     do i=1,klon
319     zmax=max(zmax,frac_nucl(i,k))
320     zmin=min(zmin,frac_nucl(i,k))
321     enddo
322     enddo
323     Print*,'------ coefs de lessivage (min et max) --------'
324     Print*,'facteur de nucleation ',zmin,zmax
325     zmin=1e33
326     zmax=-1e33
327     do k=1,klev
328     do i=1,klon
329     zmax=max(zmax,frac_impa(i,k))
330     zmin=min(zmin,frac_impa(i,k))
331     enddo
332     enddo
333     Print*,'facteur d impaction ',zmin,zmax
334    
335     ENDIF
336    
337     c reinitialisation des champs cumules
338     go to 768
339     if (mod(iadvtr,istphy).eq.1) then
340     do k=1,klev
341     do i=1,klon
342     mfu(i,k)=0.
343     mfd(i,k)=0.
344     en_u(i,k)=0.
345     de_u(i,k)=0.
346     en_d(i,k)=0.
347     de_d(i,k)=0.
348     coefh(i,k)=0.
349     t(i,k)=0.
350     fm_therm(i,k)=0.
351     entr_therm(i,k)=0.
352     enddo
353     enddo
354     do i=1,klon
355     pyv1(i)=0.
356     pyu1(i)=0.
357     end do
358     do k=1,nbsrf
359     do i=1,klon
360     pftsol(i,k)=0.
361     ppsrf(i,k)=0.
362     enddo
363     enddo
364    
365     dtcum=0.
366     endif
367    
368     do k=1,klev
369     do i=1,klon
370     mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
371     mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
372     en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
373     de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
374     en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
375     de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
376     coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
377     t(i,k)=t(i,k)+pt(i,k)*pdtphys
378     fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
379     entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
380     enddo
381     enddo
382     do i=1,klon
383     pyv1(i)=pyv1(i)+yv1(i)*pdtphys
384     pyu1(i)=pyu1(i)+yu1(i)*pdtphys
385     end do
386     do k=1,nbsrf
387     do i=1,klon
388     pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
389     ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
390     enddo
391     enddo
392    
393     dtcum=dtcum+pdtphys
394     768 continue
395    
396     RETURN
397     END

  ViewVC Help
Powered by ViewVC 1.1.21