source: dynamico_lmdz/aquaplanet/LMDZ5/libf/phylmd/phystokenc_mod.F90 @ 3831

Last change on this file since 3831 was 3831, checked in by ymipsl, 10 years ago

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