Context Navigation

phystokenc.F90 @ 2311

Last change on this file since 2311 was 2311, checked in by Ehouarn Millour, 9 years ago

Further modifications to enforce physics/dynamics separation:

moved iniprint.h and misc_mod back to dyn3d_common, as these should only be used by dynamics.
created print_control_mod in the physics to store flags prt_level, lunout, debug to be local to physics (should be used rather than iniprint.h)
created abort_physic.F90 , which does the same job as abort_gcm() did, but should be used instead when in physics.
reactivated inifis (turned it into a module, inifis_mod.F90) to initialize physical constants and print_control_mod flags.

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.4 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	USE indice_sol_mod
15	USE print_control_mod, ONLY: lunout
16
17	IMPLICIT NONE
18
19	!======================================================================
20	! Auteur(s) FH
21	! Objet: Ecriture des variables pour transport offline
22	!
23	!======================================================================
24	INCLUDE "dimensions.h"
25	INCLUDE "tracstoke.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, dtimeistphy,dtimeistphy,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

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

Download in other formats:

Original Format