source: LMDZ4/branches/LMDZ4_AR5/libf/phylmd/phystokenc.F @ 1869

Last change on this file since 1869 was 1534, checked in by musat, 13 years ago

Ajouts CFMIP2/CMIP5

  • 6eme fichier de sortie "stations" histstn.nc qui necessite 2 fichiers: PARAM/npCFMIP_param.data contenant le nombre de points (120 pour simulations AMIP, 73 pour aqua) PARAM/pointlocations.txt contenat le numero, les coordonnees (lon,lat) et le nom de chaque station
  • flag LOGICAL dans tous les appels histwrite_phy pour pouvoir sortir le fichier histstn.nc

NB: 1) les flags de type phys_ que l'on met dans le physiq.def_L* pour ajouter plus de sorties

necessitent dorenavant 6 valeurs, la 6eme correspondant au fichier histstn.nc

2) par defaut le fichier histstn.nc ne sort pas; pour le sortir ajouter les lignes suivantes

dans physiq.def_L*

### Type de fichier : global (n) ou stations (y)
phys_out_filestations = n n n n n y

  • introduction de 2 jeux de flags pour les taux des GES; taux actuels avec suffixes _act, taux futurs avec "_per" avec 2 appels au rayonnement si taux "_per" different des taux "_act" (utiles pour diags. CFMIP 4CO2)
  • flags "betaCRF" pour calculs CRF pour experiences sensibilite proprietes optiques eau liquide nuageuse avec initialisations par defaut; sinon besoin de fichier beta_crf.data

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