source: LMDZ5/branches/testing/libf/phylmd/phystokenc.F90 @ 2056

Last change on this file since 2056 was 1910, checked in by Laurent Fairhead, 11 years ago

Merged trunk changes r1860:1909 into testing branch
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.3 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  USE indice_sol_mod
15 
16  IMPLICIT NONE
17 
18!======================================================================
19! Auteur(s) FH
20! Objet: Ecriture des variables pour transport offline
21!
22!======================================================================
23  INCLUDE "dimensions.h"
24  INCLUDE "tracstoke.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  logical, parameter :: lstokenc=.FALSE.
128!
129!======================================================================
130
131  iadvtr=iadvtr+1
132
133! Dans le meme vecteur on recombine le drag et les coeff d'echange
134  pcoefh_buf(:,1)      = cdragh(:)
135  pcoefh_buf(:,2:klev) = pcoefh(:,2:klev)
136 
137  ok_sync = .TRUE.
138
139! Initialization done only once
140!======================================================================
141  IF (iadvtr==1) THEN
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     ALLOCATE(sh(klon,klev))
158     ALLOCATE(da(klon,klev))
159     ALLOCATE(phi(klon,klev,klev))
160     ALLOCATE(mp(klon,klev))
161     ALLOCATE(upwd(klon,klev))
162     ALLOCATE(dnwd(klon,klev))
163
164     CALL initphysto('phystoke', dtime, dtime*istphy,dtime*istphy,physid)
165     
166     ! Write field phis and aire only once
167     CALL histwrite_phy(physid,lstokenc,"phis",itap,pphis)
168     CALL histwrite_phy(physid,lstokenc,"aire",itap,paire)
169     CALL histwrite_phy(physid,lstokenc,"longitudes",itap,rlon)
170     CALL histwrite_phy(physid,lstokenc,"latitudes",itap,rlat)
171
172  END IF
173 
174 
175! Set to zero cumulating fields
176!======================================================================
177  IF (MOD(iadvtr,istphy)==1.OR.istphy==1) THEN
178     WRITE(lunout,*)'reinitialisation des champs cumules a iadvtr=',iadvtr
179     mfu(:,:)=0.
180     mfd(:,:)=0.
181     en_u(:,:)=0.
182     de_u(:,:)=0.
183     en_d(:,:)=0.
184     de_d(:,:)=0.
185     coefh(:,:)=0.
186     t(:,:)=0.
187     fm_therm(:,:)=0.
188     entr_therm(:,:)=0.
189     pyv1(:)=0.
190     pyu1(:)=0.
191     pftsol(:,:)=0.
192     ppsrf(:,:)=0.
193     sh(:,:)=0.
194     da(:,:)=0.
195     phi(:,:,:)=0.
196     mp(:,:)=0.
197     upwd(:,:)=0.
198     dnwd(:,:)=0.
199     dtcum=0.
200  ENDIF
201 
202
203! Cumulate fields at each time step
204!======================================================================
205  DO k=1,klev
206     DO i=1,klon
207        mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
208        mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
209        en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
210        de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
211        en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
212        de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
213        coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys
214        t(i,k)=t(i,k)+pt(i,k)*pdtphys
215        fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
216        entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
217        sh(i,k) = sh(i,k) + psh(i,k)*pdtphys
218        da(i,k) = da(i,k) + pda(i,k)*pdtphys
219        mp(i,k) = mp(i,k) + pmp(i,k)*pdtphys
220        upwd(i,k) = upwd(i,k) + pupwd(i,k)*pdtphys
221        dnwd(i,k) = dnwd(i,k) + pdnwd(i,k)*pdtphys
222     ENDDO
223  ENDDO
224
225  DO kk=1,klev
226     DO k=1,klev
227        DO i=1,klon
228           phi(i,k,kk) = phi(i,k,kk) + pphi(i,k,kk)*pdtphys
229        END DO
230     END DO
231  END DO
232
233  DO i=1,klon
234     pyv1(i)=pyv1(i)+yv1(i)*pdtphys
235     pyu1(i)=pyu1(i)+yu1(i)*pdtphys
236  END DO
237  DO k=1,nbsrf
238     DO i=1,klon
239        pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
240        ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
241     ENDDO
242  ENDDO
243 
244! Add time step to cumulated time
245  dtcum=dtcum+pdtphys
246 
247
248! Write fields to file, if it is time to do so
249!======================================================================
250  IF(MOD(iadvtr,istphy)==0) THEN
251
252     ! normalize with time period
253     DO k=1,klev
254        DO i=1,klon
255           mfu(i,k)=mfu(i,k)/dtcum
256           mfd(i,k)=mfd(i,k)/dtcum
257           en_u(i,k)=en_u(i,k)/dtcum
258           de_u(i,k)=de_u(i,k)/dtcum
259           en_d(i,k)=en_d(i,k)/dtcum
260           de_d(i,k)=de_d(i,k)/dtcum
261           coefh(i,k)=coefh(i,k)/dtcum
262           t(i,k)=t(i,k)/dtcum 
263           fm_therm(i,k)=fm_therm(i,k)/dtcum
264           entr_therm(i,k)=entr_therm(i,k)/dtcum
265           sh(i,k)=sh(i,k)/dtcum
266           da(i,k)=da(i,k)/dtcum
267           mp(i,k)=mp(i,k)/dtcum
268           upwd(i,k)=upwd(i,k)/dtcum
269           dnwd(i,k)=dnwd(i,k)/dtcum
270        ENDDO
271     ENDDO
272     DO kk=1,klev
273        DO k=1,klev
274           DO i=1,klon
275              phi(i,k,kk) = phi(i,k,kk)/dtcum
276           END DO
277        END DO
278     END DO
279     DO i=1,klon
280        pyv1(i)=pyv1(i)/dtcum
281        pyu1(i)=pyu1(i)/dtcum
282     END DO
283     DO k=1,nbsrf
284        DO i=1,klon
285           pftsol(i,k)=pftsol(i,k)/dtcum
286           ppsrf(i,k)=ppsrf(i,k)/dtcum
287        ENDDO
288     ENDDO
289
290     ! write fields
291     CALL histwrite_phy(physid,lstokenc,"t",itap,t)
292     CALL histwrite_phy(physid,lstokenc,"mfu",itap,mfu)
293     CALL histwrite_phy(physid,lstokenc,"mfd",itap,mfd)
294     CALL histwrite_phy(physid,lstokenc,"en_u",itap,en_u)
295     CALL histwrite_phy(physid,lstokenc,"de_u",itap,de_u)
296     CALL histwrite_phy(physid,lstokenc,"en_d",itap,en_d)
297     CALL histwrite_phy(physid,lstokenc,"de_d",itap,de_d)
298     CALL histwrite_phy(physid,lstokenc,"coefh",itap,coefh)     
299     CALL histwrite_phy(physid,lstokenc,"fm_th",itap,fm_therm)
300     CALL histwrite_phy(physid,lstokenc,"en_th",itap,entr_therm)
301     CALL histwrite_phy(physid,lstokenc,"frac_impa",itap,frac_impa)
302     CALL histwrite_phy(physid,lstokenc,"frac_nucl",itap,frac_nucl)
303     CALL histwrite_phy(physid,lstokenc,"pyu1",itap,pyu1)
304     CALL histwrite_phy(physid,lstokenc,"pyv1",itap,pyv1)
305     CALL histwrite_phy(physid,lstokenc,"ftsol1",itap,pftsol(:,1))
306     CALL histwrite_phy(physid,lstokenc,"ftsol2",itap,pftsol(:,2))
307     CALL histwrite_phy(physid,lstokenc,"ftsol3",itap,pftsol(:,3))
308     CALL histwrite_phy(physid,lstokenc,"ftsol4",itap,pftsol(:,4))
309     CALL histwrite_phy(physid,lstokenc,"psrf1",itap,ppsrf(:,1))
310     CALL histwrite_phy(physid,lstokenc,"psrf2",itap,ppsrf(:,2))
311     CALL histwrite_phy(physid,lstokenc,"psrf3",itap,ppsrf(:,3))
312     CALL histwrite_phy(physid,lstokenc,"psrf4",itap,ppsrf(:,4))
313     CALL histwrite_phy(physid,lstokenc,"sh",itap,sh)
314     CALL histwrite_phy(physid,lstokenc,"da",itap,da)
315     CALL histwrite_phy(physid,lstokenc,"mp",itap,mp)
316     CALL histwrite_phy(physid,lstokenc,"upwd",itap,upwd)
317     CALL histwrite_phy(physid,lstokenc,"dnwd",itap,dnwd)
318
319
320! phi
321     DO k=1,klev
322        IF (k<10) THEN
323           WRITE(nvar,'(i1)') k
324        ELSE IF (k<100) THEN
325           WRITE(nvar,'(i2)') k
326        ELSE
327           WRITE(nvar,'(i3)') k
328        END IF
329        nvar='phi_lev'//trim(nvar)
330       
331        CALL histwrite_phy(physid,lstokenc,nvar,itap,phi(:,:,k))
332     END DO
333     
334     ! Syncronize file
335!$OMP MASTER
336     IF (ok_sync) CALL histsync(physid)
337!$OMP END MASTER
338     
339     
340     ! Calculate min and max values for some fields (coefficients de lessivage)
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     WRITE(lunout,*)'------ coefs de lessivage (min et max) --------'
350     WRITE(lunout,*)'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     WRITE(lunout,*)'facteur d impaction ',zmin,zmax
360     
361  ENDIF ! IF(MOD(iadvtr,istphy)==0)
362
363END SUBROUTINE phystokenc
Note: See TracBrowser for help on using the repository browser.