source: LMDZ5/branches/LMDZ5V1.0-dev/libf/phylmd/phystokenc.F90 @ 2529

Last change on this file since 2529 was 1447, checked in by jghattas, 14 years ago
  • Added variables written to file phystokenc.nc by option offline.
  • initphysto and phystokenc rewritten in F90
  • ener.h modified to be compatible with F77 and F90 syntax
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.0 KB
Line 
1SUBROUTINE phystokenc (nlon,nlev,pdtphys,rlon,rlat, &
2     pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
3     pfm_therm,pentr_therm, &
4     cdragh, pcoefh,yu1,yv1,ftsol,pctsrf, &
5     frac_impa,frac_nucl, &
6     pphis,paire,dtime,itap, &
7     psh, pda, pphi, pmp, pupwd, pdnwd)
8 
9  USE ioipsl
10  USE dimphy
11  USE infotrac, ONLY : nqtot
12  USE iophy
13  USE control_mod
14 
15  IMPLICIT NONE
16 
17!======================================================================
18! Auteur(s) FH
19! Objet: Ecriture des variables pour transport offline
20!
21!======================================================================
22  INCLUDE "dimensions.h"
23  INCLUDE "tracstoke.h"
24  INCLUDE "indicesol.h"
25  INCLUDE "iniprint.h"
26!======================================================================
27
28! Arguments:
29!
30  REAL,DIMENSION(klon,klev), INTENT(IN)     :: psh   ! humidite specifique
31  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pda
32  REAL,DIMENSION(klon,klev,klev), INTENT(IN):: pphi
33  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pmp
34  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pupwd ! saturated updraft mass flux
35  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pdnwd ! saturated downdraft mass flux
36
37!   EN ENTREE:
38!   ==========
39!
40!   divers:
41!   -------
42!
43  INTEGER nlon ! nombre de points horizontaux
44  INTEGER nlev ! nombre de couches verticales
45  REAL pdtphys ! pas d'integration pour la physique (seconde)
46  INTEGER itap
47  INTEGER, SAVE :: physid
48!$OMP THREADPRIVATE(physid)
49
50!   convection:
51!   -----------
52!
53  REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
54  REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
55  REAL pen_u(klon,klev) ! flux entraine dans le panache montant
56  REAL pde_u(klon,klev) ! flux detraine dans le panache montant
57  REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
58  REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
59  REAL pt(klon,klev)
60  REAL,ALLOCATABLE,SAVE :: t(:,:)
61!$OMP THREADPRIVATE(t)
62!
63  REAL rlon(klon), rlat(klon), dtime
64  REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
65
66!   Couche limite:
67!   --------------
68!
69  REAL cdragh(klon)          ! cdrag
70  REAL pcoefh(klon,klev)     ! coeff melange CL
71  REAL pcoefh_buf(klon,klev) ! coeff melange CL + cdrag
72  REAL yv1(klon)
73  REAL yu1(klon),pphis(klon),paire(klon)
74
75!   Les Thermiques : (Abderr 25 11 02)
76!   ---------------
77  REAL, INTENT(IN) ::  pfm_therm(klon,klev+1)
78  REAL pentr_therm(klon,klev)
79 
80  REAL,ALLOCATABLE,SAVE :: entr_therm(:,:)
81  REAL,ALLOCATABLE,SAVE :: fm_therm(:,:)
82!$OMP THREADPRIVATE(entr_therm)
83!$OMP THREADPRIVATE(fm_therm)
84!
85!   Lessivage:
86!   ----------
87!
88  REAL frac_impa(klon,klev)
89  REAL frac_nucl(klon,klev)
90!
91! Arguments necessaires pour les sources et puits de traceur
92!
93  REAL ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
94  REAL pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
95!======================================================================
96!
97  INTEGER i, k, kk
98  REAL,ALLOCATABLE,SAVE :: mfu(:,:)  ! flux de masse dans le panache montant
99  REAL,ALLOCATABLE,SAVE :: mfd(:,:)  ! flux de masse dans le panache descendant
100  REAL,ALLOCATABLE,SAVE :: en_u(:,:) ! flux entraine dans le panache montant
101  REAL,ALLOCATABLE,SAVE :: de_u(:,:) ! flux detraine dans le panache montant
102  REAL,ALLOCATABLE,SAVE :: en_d(:,:) ! flux entraine dans le panache descendant
103  REAL,ALLOCATABLE,SAVE :: de_d(:,:) ! flux detraine dans le panache descendant
104  REAL,ALLOCATABLE,SAVE :: coefh(:,:) ! flux detraine dans le panache descendant
105 
106  REAL,ALLOCATABLE,SAVE :: pyu1(:)
107  REAL,ALLOCATABLE,SAVE :: pyv1(:)
108  REAL,ALLOCATABLE,SAVE :: pftsol(:,:)
109  REAL,ALLOCATABLE,SAVE :: ppsrf(:,:)
110!$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh)
111!$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf)
112
113
114  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: sh 
115  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: da
116  REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE   :: phi
117  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: mp
118  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: upwd
119  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: dnwd
120 
121  REAL, SAVE :: dtcum
122  INTEGER, SAVE:: iadvtr=0
123!$OMP THREADPRIVATE(dtcum,iadvtr)
124  REAL zmin,zmax
125  LOGICAL ok_sync
126  CHARACTER(len=12) :: nvar
127!
128!======================================================================
129
130  iadvtr=iadvtr+1
131
132! Dans le meme vecteur on recombine le drag et les coeff d'echange
133  pcoefh_buf(:,1)      = cdragh(:)
134  pcoefh_buf(:,2:klev) = pcoefh(:,2:klev)
135 
136  ok_sync = .TRUE.
137
138! Initialization done only once
139!======================================================================
140  IF (iadvtr==1) THEN
141     ALLOCATE( t(klon,klev))
142     ALLOCATE( mfu(klon,klev)) 
143     ALLOCATE( mfd(klon,klev)) 
144     ALLOCATE( en_u(klon,klev))
145     ALLOCATE( de_u(klon,klev))
146     ALLOCATE( en_d(klon,klev))
147     ALLOCATE( de_d(klon,klev))
148     ALLOCATE( coefh(klon,klev))
149     ALLOCATE( entr_therm(klon,klev))
150     ALLOCATE( fm_therm(klon,klev))
151     ALLOCATE( pyu1(klon))
152     ALLOCATE( pyv1(klon))
153     ALLOCATE( pftsol(klon,nbsrf))
154     ALLOCATE( ppsrf(klon,nbsrf))
155     
156     ALLOCATE(sh(klon,klev))
157     ALLOCATE(da(klon,klev))
158     ALLOCATE(phi(klon,klev,klev))
159     ALLOCATE(mp(klon,klev))
160     ALLOCATE(upwd(klon,klev))
161     ALLOCATE(dnwd(klon,klev))
162
163     CALL initphysto('phystoke', dtime, dtime*istphy,dtime*istphy,physid)
164     
165     ! Write field phis and aire only once
166     CALL histwrite_phy(physid,"phis",itap,pphis)
167     CALL histwrite_phy(physid,"aire",itap,paire)
168     CALL histwrite_phy(physid,"longitudes",itap,rlon)
169     CALL histwrite_phy(physid,"latitudes",itap,rlat)
170
171  END IF
172 
173 
174! Set to zero cumulating fields
175!======================================================================
176  IF (MOD(iadvtr,istphy)==1.OR.istphy==1) THEN
177     WRITE(lunout,*)'reinitialisation des champs cumules a iadvtr=',iadvtr
178     mfu(:,:)=0.
179     mfd(:,:)=0.
180     en_u(:,:)=0.
181     de_u(:,:)=0.
182     en_d(:,:)=0.
183     de_d(:,:)=0.
184     coefh(:,:)=0.
185     t(:,:)=0.
186     fm_therm(:,:)=0.
187     entr_therm(:,:)=0.
188     pyv1(:)=0.
189     pyu1(:)=0.
190     pftsol(:,:)=0.
191     ppsrf(:,:)=0.
192     sh(:,:)=0.
193     da(:,:)=0.
194     phi(:,:,:)=0.
195     mp(:,:)=0.
196     upwd(:,:)=0.
197     dnwd(:,:)=0.
198     dtcum=0.
199  ENDIF
200 
201
202! Cumulate fields at each time step
203!======================================================================
204  DO k=1,klev
205     DO i=1,klon
206        mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
207        mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
208        en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
209        de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
210        en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
211        de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
212        coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys
213        t(i,k)=t(i,k)+pt(i,k)*pdtphys
214        fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
215        entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
216        sh(i,k) = sh(i,k) + psh(i,k)*pdtphys
217        da(i,k) = da(i,k) + pda(i,k)*pdtphys
218        mp(i,k) = mp(i,k) + pmp(i,k)*pdtphys
219        upwd(i,k) = upwd(i,k) + pupwd(i,k)*pdtphys
220        dnwd(i,k) = dnwd(i,k) + pdnwd(i,k)*pdtphys
221     ENDDO
222  ENDDO
223
224  DO kk=1,klev
225     DO k=1,klev
226        DO i=1,klon
227           phi(i,k,kk) = phi(i,k,kk) + pphi(i,k,kk)*pdtphys
228        END DO
229     END DO
230  END DO
231
232  DO i=1,klon
233     pyv1(i)=pyv1(i)+yv1(i)*pdtphys
234     pyu1(i)=pyu1(i)+yu1(i)*pdtphys
235  END DO
236  DO k=1,nbsrf
237     DO i=1,klon
238        pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
239        ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
240     ENDDO
241  ENDDO
242 
243! Add time step to cumulated time
244  dtcum=dtcum+pdtphys
245 
246
247! Write fields to file, if it is time to do so
248!======================================================================
249  IF(MOD(iadvtr,istphy)==0) THEN
250
251     ! normalize with time period
252     DO k=1,klev
253        DO i=1,klon
254           mfu(i,k)=mfu(i,k)/dtcum
255           mfd(i,k)=mfd(i,k)/dtcum
256           en_u(i,k)=en_u(i,k)/dtcum
257           de_u(i,k)=de_u(i,k)/dtcum
258           en_d(i,k)=en_d(i,k)/dtcum
259           de_d(i,k)=de_d(i,k)/dtcum
260           coefh(i,k)=coefh(i,k)/dtcum
261           t(i,k)=t(i,k)/dtcum 
262           fm_therm(i,k)=fm_therm(i,k)/dtcum
263           entr_therm(i,k)=entr_therm(i,k)/dtcum
264           sh(i,k)=sh(i,k)/dtcum
265           da(i,k)=da(i,k)/dtcum
266           mp(i,k)=mp(i,k)/dtcum
267           upwd(i,k)=upwd(i,k)/dtcum
268           dnwd(i,k)=dnwd(i,k)/dtcum
269        ENDDO
270     ENDDO
271     DO kk=1,klev
272        DO k=1,klev
273           DO i=1,klon
274              phi(i,k,kk) = phi(i,k,kk)/dtcum
275           END DO
276        END DO
277     END DO
278     DO i=1,klon
279        pyv1(i)=pyv1(i)/dtcum
280        pyu1(i)=pyu1(i)/dtcum
281     END DO
282     DO k=1,nbsrf
283        DO i=1,klon
284           pftsol(i,k)=pftsol(i,k)/dtcum
285           ppsrf(i,k)=ppsrf(i,k)/dtcum
286        ENDDO
287     ENDDO
288
289     ! write fields
290     CALL histwrite_phy(physid,"t",itap,t)
291     CALL histwrite_phy(physid,"mfu",itap,mfu)
292     CALL histwrite_phy(physid,"mfd",itap,mfd)
293     CALL histwrite_phy(physid,"en_u",itap,en_u)
294     CALL histwrite_phy(physid,"de_u",itap,de_u)
295     CALL histwrite_phy(physid,"en_d",itap,en_d)
296     CALL histwrite_phy(physid,"de_d",itap,de_d)
297     CALL histwrite_phy(physid,"coefh",itap,coefh)     
298     CALL histwrite_phy(physid,"fm_th",itap,fm_therm)
299     CALL histwrite_phy(physid,"en_th",itap,entr_therm)
300     CALL histwrite_phy(physid,"frac_impa",itap,frac_impa)
301     CALL histwrite_phy(physid,"frac_nucl",itap,frac_nucl)
302     CALL histwrite_phy(physid,"pyu1",itap,pyu1)
303     CALL histwrite_phy(physid,"pyv1",itap,pyv1)
304     CALL histwrite_phy(physid,"ftsol1",itap,pftsol(:,1))
305     CALL histwrite_phy(physid,"ftsol2",itap,pftsol(:,2))
306     CALL histwrite_phy(physid,"ftsol3",itap,pftsol(:,3))
307     CALL histwrite_phy(physid,"ftsol4",itap,pftsol(:,4))
308     CALL histwrite_phy(physid,"psrf1",itap,ppsrf(:,1))
309     CALL histwrite_phy(physid,"psrf2",itap,ppsrf(:,2))
310     CALL histwrite_phy(physid,"psrf3",itap,ppsrf(:,3))
311     CALL histwrite_phy(physid,"psrf4",itap,ppsrf(:,4))
312     CALL histwrite_phy(physid,"sh",itap,sh)
313     CALL histwrite_phy(physid,"da",itap,da)
314     CALL histwrite_phy(physid,"mp",itap,mp)
315     CALL histwrite_phy(physid,"upwd",itap,upwd)
316     CALL histwrite_phy(physid,"dnwd",itap,dnwd)
317
318
319! phi
320     DO k=1,klev
321        IF (k<10) THEN
322           WRITE(nvar,'(i1)') k
323        ELSE IF (k<100) THEN
324           WRITE(nvar,'(i2)') k
325        ELSE
326           WRITE(nvar,'(i3)') k
327        END IF
328        nvar='phi_lev'//trim(nvar)
329       
330        CALL histwrite_phy(physid,nvar,itap,phi(:,:,k))
331     END DO
332     
333     ! Syncronize file
334!$OMP MASTER
335     IF (ok_sync) CALL histsync(physid)
336!$OMP END MASTER
337     
338     
339     ! Calculate min and max values for some fields (coefficients de lessivage)
340     zmin=1e33
341     zmax=-1e33
342     DO k=1,klev
343        DO i=1,klon
344           zmax=MAX(zmax,frac_nucl(i,k))
345           zmin=MIN(zmin,frac_nucl(i,k))
346        ENDDO
347     ENDDO
348     WRITE(lunout,*)'------ coefs de lessivage (min et max) --------'
349     WRITE(lunout,*)'facteur de nucleation ',zmin,zmax
350     zmin=1e33
351     zmax=-1e33
352     DO k=1,klev
353        DO i=1,klon
354           zmax=MAX(zmax,frac_impa(i,k))
355           zmin=MIN(zmin,frac_impa(i,k))
356        ENDDO
357     ENDDO
358     WRITE(lunout,*)'facteur d impaction ',zmin,zmax
359     
360  ENDIF ! IF(MOD(iadvtr,istphy)==0)
361
362END SUBROUTINE phystokenc
Note: See TracBrowser for help on using the repository browser.