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

Last change on this file since 665 was 541, checked in by lmdzadmin, 21 years ago

Convergence avec la version d'Olivia Coindreau incluant:

  • le offline
  • les thermiques
  • mellor & yamada dans la couche limite

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