My Project
 All Classes Files Functions Variables Macros
phystokenc.F90
Go to the documentation of this file.
1 SUBROUTINE 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  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 
363 END SUBROUTINE phystokenc