source: LMDZ4/branches/LMDZ4_par_0/libf/phylmd/phystokenc.F @ 5456

Last change on this file since 5456 was 634, checked in by Laurent Fairhead, 20 years ago

Modifications faites à la physique pour la rendre parallele YM
Une branche de travail LMDZ4_par_0 a été créée provisoirement afin de tester
les modifs pleinement avant leurs inclusions dans le tronc principal
LF

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