Context Navigation

phystokenc.F90 @ 5440

Last change on this file since 5440 was 1454, checked in by Laurent Fairhead, 14 years ago

Merge of LMDZ5V1.0-dev branch r1453 into LMDZ5 trunk r1434

Fusion entre la version r1453 de la branche de développement LMDZ5V1.0-dev
et le tronc LMDZ5 (r1434)

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 11.0 KB

Line
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	!
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, dtimeistphy,dtimeistphy,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
362	END SUBROUTINE phystokenc

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format