source: LMDZ4/trunk/libf/phylmd/phystokenc.F @ 532

Last change on this file since 532 was 524, checked in by lmdzadmin, 21 years ago

Initial revision
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.1 KB
RevLine 
[524]1!
2! $Header$
3!
4c
5c
6      SUBROUTINE phystokenc (
7     I                   nlon,nlev,pdtphys,rlon,rlat,
8     I                   pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
9     I                   pcoefh,yu1,yv1,ftsol,pctsrf,
10     I                   pfrac_impa,pfrac_nucl,
11     I                   pphis,paire,dtime,itap)
12      USE ioipsl
13      USE histcom
14
15      IMPLICIT none
16
17c======================================================================
18c Auteur(s) FH
19c Objet: Moniteur general des tendances traceurs
20c
21
22c======================================================================
23#include "dimensions.h"
24#include "dimphy.h"
25#include "tracstoke.h"
26#include "indicesol.h"
27#include "control.h"
28c======================================================================
29
30c Arguments:
31c
32c   EN ENTREE:
33c   ==========
34c
35c   divers:
36c   -------
37c
38      integer nlon ! nombre de points horizontaux
39      integer nlev ! nombre de couches verticales
40      real pdtphys ! pas d'integration pour la physique (seconde)
41c
42      integer physid, itap,ndex(1)
43
44c   convection:
45c   -----------
46c
47      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
48      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
49      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
50      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
51      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
52      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
53        REAL pt(klon,klev)
54c
55      REAL rlon(klon), rlat(klon), dtime
56      REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
57
58c   Couche limite:
59c   --------------
60c
61      REAL pcoefh(klon,klev)    ! coeff melange CL
62      REAL yv1(klon)
63      REAL yu1(klon),pphis(klon),paire(klon)
64c
65c   Lessivage:
66c   ----------
67c
68      REAL pfrac_impa(klon,klev)
69      REAL pfrac_nucl(klon,klev)
70c
71c Arguments necessaires pour les sources et puits de traceur
72C
73      real ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
74      real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
75c======================================================================
76c
77      INTEGER i, k
78c
79      REAL mfu(klon,klev)  ! flux de masse dans le panache montant
80      REAL mfd(klon,klev)  ! flux de masse dans le panache descendant
81      REAL en_u(klon,klev) ! flux entraine dans le panache montant
82      REAL de_u(klon,klev) ! flux detraine dans le panache montant
83      REAL en_d(klon,klev) ! flux entraine dans le panache descendant
84      REAL de_d(klon,klev) ! flux detraine dans le panache descendant
85      REAL coefh(klon,klev) ! flux detraine dans le panache descendant
86        REAL t(klon,klev)
87      REAL frac_impa(klon,klev)
88      REAL frac_nucl(klon,klev)
89      REAL rain(klon)
90
91      REAL pyu1(klon),pyv1(klon)
92      REAL pftsol(klon,nbsrf),ppsrf(klon,nbsrf)
93      real pftsol1(klon),pftsol2(klon),pftsol3(klon),pftsol4(klon)
94      real ppsrf1(klon),ppsrf2(klon),ppsrf3(klon),ppsrf4(klon)
95
96      REAL dtcum
97
98      integer iadvtr,irec
99      real zmin,zmax
100
101      save t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum
102      save iadvtr,irec
103      save frac_impa,frac_nucl,rain
104      save pyu1,pyv1,pftsol,ppsrf
105
106      data iadvtr,irec/0,1/
107c
108c   Couche limite:
109c======================================================================
110
111      print*,'iadvtr= ',iadvtr
112      print*,'istphy= ',istphy
113      print*,'istdyn= ',istdyn
114
115      IF (iadvtr.eq.0) THEN
116       
117        CALL initphysto('phystoke',
118     . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqmx,physid)
119       
120        write(*,*) 'apres initphysto ds phystokenc'
121
122       ndex(1) = 0
123         i=itap
124         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
125         CALL histwrite(physid,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
126c
127         i=itap
128         CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
129         CALL histwrite(physid,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
130       
131      ENDIF
132c
133      iadvtr=iadvtr+1
134c
135c
136c   reinitialisation des champs cumules
137      if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then
138        print*,'reinitialisation des champs cumules
139     s          a iadvtr=',iadvtr
140         do k=1,klev
141            do i=1,klon
142               frac_impa(i,k)=1.
143               frac_nucl(i,k)=1.
144               mfu(i,k)=0.
145               mfd(i,k)=0.
146               en_u(i,k)=0.
147               de_u(i,k)=0.
148               en_d(i,k)=0.
149               de_d(i,k)=0.
150               coefh(i,k)=0.
151                t(i,k)=0.
152            enddo
153         enddo
154         do i=1,klon
155            rain(i)=0.
156            pyv1(i)=0.
157            pyu1(i)=0.
158         end do
159         do k=1,nbsrf
160             do i=1,klon
161               pftsol(i,k)=0.
162               ppsrf(i,k)=0.
163            enddo
164         enddo
165
166         dtcum=0.
167      endif
168
169      do k=1,klev
170         do i=1,klon
171            frac_impa(i,k)=frac_impa(i,k)*pfrac_impa(i,k)
172            frac_nucl(i,k)=frac_nucl(i,k)*pfrac_nucl(i,k)
173            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
174            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
175            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
176            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
177            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
178            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
179            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
180                t(i,k)=t(i,k)+pt(i,k)*pdtphys
181         enddo
182      enddo
183         do i=1,klon
184            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
185            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
186         end do
187         do k=1,nbsrf
188             do i=1,klon
189               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
190               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
191            enddo
192         enddo
193
194      dtcum=dtcum+pdtphys
195c
196      IF(mod(iadvtr,istphy).eq.0) THEN
197c
198c   normalisation par le temps cumule
199         do k=1,klev
200            do i=1,klon
201c              frac_impa=frac_impa : c'est la fraction cumulee qu'on stoke
202c              frac_nucl=frac_nucl : c'est la fraction cumulee qu'on stoke
203               mfu(i,k)=mfu(i,k)/dtcum
204               mfd(i,k)=mfd(i,k)/dtcum
205               en_u(i,k)=en_u(i,k)/dtcum
206               de_u(i,k)=de_u(i,k)/dtcum
207               en_d(i,k)=en_d(i,k)/dtcum
208               de_d(i,k)=de_d(i,k)/dtcum
209               coefh(i,k)=coefh(i,k)/dtcum
210                t(i,k)=t(i,k)/dtcum
211            enddo
212         enddo
213         do i=1,klon
214            rain(i)=rain(i)/dtcum
215            pyv1(i)=pyv1(i)/dtcum
216            pyu1(i)=pyu1(i)/dtcum
217         end do
218c modif abderr 23 11 00         do k=1,nbsrf
219             do i=1,klon
220              do k=1,nbsrf
221               pftsol(i,k)=pftsol(i,k)/dtcum
222               ppsrf(i,k)=ppsrf(i,k)/dtcum
223              enddo
224               pftsol1(i) = pftsol(i,1)
225               pftsol2(i) = pftsol(i,2)
226               pftsol3(i) = pftsol(i,3)
227               pftsol4(i) = pftsol(i,4)
228
229c               ppsrf(i,k)=ppsrf(i,k)/dtcum
230               ppsrf1(i) = ppsrf(i,1)
231               ppsrf2(i) = ppsrf(i,2)
232               ppsrf3(i) = ppsrf(i,3)
233               ppsrf4(i) = ppsrf(i,4)
234
235            enddo
236c         enddo
237c
238c   ecriture des champs
239c
240         irec=irec+1
241
242ccccc
243      print*,'AVANT ECRITURE'
244         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
245         CALL histwrite(physid,"t",itap,zx_tmp_3d,
246     .                                   iim*(jjm+1)*klev,ndex)
247      print*,'APRES ECRITURE'
248
249         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
250      CALL histwrite(physid,"mfu",itap,zx_tmp_3d,
251     .                                   iim*(jjm+1)*klev,ndex)
252        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
253      CALL histwrite(physid,"mfd",itap,zx_tmp_3d,
254     .                                   iim*(jjm+1)*klev,ndex)
255        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
256      CALL histwrite(physid,"en_u",itap,zx_tmp_3d,
257     .                                   iim*(jjm+1)*klev,ndex)
258        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
259      CALL histwrite(physid,"de_u",itap,zx_tmp_3d,
260     .                                   iim*(jjm+1)*klev,ndex)
261        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
262      CALL histwrite(physid,"en_d",itap,zx_tmp_3d,
263     .                                   iim*(jjm+1)*klev,ndex)
264        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)
265      CALL histwrite(physid,"de_d",itap,zx_tmp_3d,
266     .                                   iim*(jjm+1)*klev,ndex)
267        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)
268      CALL histwrite(physid,"coefh",itap,zx_tmp_3d,
269     .                                   iim*(jjm+1)*klev,ndex)
270cccc
271       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
272        CALL histwrite(physid,"frac_impa",itap,zx_tmp_3d,
273     .  iim*(jjm+1)*klev,ndex)
274
275        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
276        CALL histwrite(physid,"frac_nucl",itap,zx_tmp_3d,
277     .  iim*(jjm+1)*klev,ndex)
278
279        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
280      CALL histwrite(physid,"pyu1",itap,zx_tmp_2d,iim*(jjm+1),ndex)
281
282        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
283      CALL histwrite(physid,"pyv1",itap,zx_tmp_2d,iim*(jjm+1),ndex)
284
285        CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
286      CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d,
287     .                                   iim*(jjm+1),ndex)
288         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
289      CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d,
290     .                                   iim*(jjm+1),ndex)
291          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
292      CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d,
293     .                                   iim*(jjm+1),ndex)
294
295c
296         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
297      CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d,
298     .                                   iim*(jjm+1),ndex)
299
300        CALL gr_fi_ecrit(1,klon,iim,jjm+1, rain, zx_tmp_2d)
301      CALL histwrite(physid,"rain",itap,zx_tmp_2d,
302     .                                   iim*(jjm+1),ndex)
303
304        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
305      CALL histwrite(physid,"psrf1",itap,zx_tmp_2d,
306     .                                   iim*(jjm+1),ndex)
307        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
308      CALL histwrite(physid,"psrf2",itap,zx_tmp_2d,
309     .                                   iim*(jjm+1),ndex)
310        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
311      CALL histwrite(physid,"psrf3",itap,zx_tmp_2d,
312     .                                   iim*(jjm+1),ndex)
313        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
314      CALL histwrite(physid,"psrf4",itap,zx_tmp_2d,
315     .                                   iim*(jjm+1),ndex)
316
317c
318cAA Test sur la valeur des coefficients de lessivage
319c
320         zmin=1e33
321         zmax=-1e33
322         do k=1,klev
323            do i=1,klon
324                  zmax=max(zmax,frac_nucl(i,k))
325                  zmin=min(zmin,frac_nucl(i,k))
326            enddo
327         enddo
328         Print*,'------ coefs de lessivage (min et max) --------'
329         Print*,'facteur de nucleation ',zmin,zmax
330         zmin=1e33
331         zmax=-1e33
332         do k=1,klev
333            do i=1,klon
334                  zmax=max(zmax,frac_impa(i,k))
335                  zmin=min(zmin,frac_impa(i,k))
336            enddo
337         enddo
338         Print*,'facteur d impaction ',zmin,zmax
339
340      ENDIF
341
342
343      RETURN
344      END
Note: See TracBrowser for help on using the repository browser.