Context Navigation

read_pstoke0.F @ 1907

Last change on this file since 1907 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

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: 15.1 KB

Line
1	!
2	! $Id: read_pstoke0.F 1907 2013-11-26 13:10:46Z lguez $
3	!
4	c
5	c
6	subroutine read_pstoke0(irec,
7	. zrec,zkon,zkev,airefi,phisfi,
8	. t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
9	. fm_therm,en_therm,
10	. frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
11
12	C******************************************************************************
13	C Frederic HOURDIN, Abderrahmane IDELKADI
14	C Lecture des parametres physique stockes online necessaires pour
15	C recalculer offline le transport des traceurs sur la meme grille que online
16	C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
17	C******************************************************************************
18
19	USE netcdf
20	USE dimphy
21	USE control_mod
22	USE indice_sol_mod
23
24	IMPLICIT NONE
25
26	#include "netcdf.inc"
27	#include "dimensions.h"
28	#include "paramet.h"
29	#include "comconst.h"
30	#include "comgeom.h"
31	#include "temps.h"
32	#include "ener.h"
33	#include "logic.h"
34	#include "description.h"
35	#include "serre.h"
36	cccc#include "dimphy.h"
37
38	integer kon,kev,zkon,zkev
39	parameter(kon=iim*(jjm-1)+2,kev=llm)
40	REAL phisfi(kon)
41	REAL phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
42
43	REAL mfu(kon,kev), mfd(kon,kev)
44	REAL en_u(kon,kev), de_u(kon,kev)
45	REAL en_d(kon,kev), de_d(kon,kev)
46	REAL coefh(kon,kev)
47
48	c abd 25 11 02
49	c Thermiques
50	REAL fm_therm(kon,kev),en_therm(kon,kev)
51	REAL t(kon,kev)
52
53	REAL mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
54	REAL en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
55	REAL en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
56	REAL coefh2(iim,jjm+1,kev)
57	REAL t2(iim,jjm+1,kev)
58	c Thermiques
59	REAL fm_therm2(iim,jjm+1,kev)
60	REAL en_therm2(iim,jjm+1,kev)
61
62	REAL pl(kev)
63	integer irec
64	integer xid,yid,zid,tid
65	integer zrec,zim,zjm
66	integer ncrec,nckon,nckev,ncim,ncjm
67
68	real airefi(kon)
69	character*20 namedim
70
71	c !! attention !!
72	c attention il y a aussi le pb de def kon
73	c dim de phis??
74
75	REAL frac_impa(kon,kev), frac_nucl(kon,kev)
76	REAL frac_impa2(iim,jjm+1,kev),
77	. frac_nucl2(iim,jjm+1,kev)
78	REAL pyu1(kon), pyv1(kon)
79	REAL pyu12(iim,jjm+1), pyv12(iim,jjm+1)
80	REAL ftsol(kon,nbsrf)
81	REAL psrf(kon,nbsrf)
82	REAL ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
83	REAL psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
84	REAL ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
85	. ftsol32(iim,jjm+1),
86	. ftsol42(iim,jjm+1)
87	REAL psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
88	. psrf42(iim,jjm+1)
89
90	integer ncidp
91	save ncidp
92	integer varidmfu, varidmfd, varidps, varidenu, variddeu
93	integer varidt
94	integer varidend,varidded,varidch,varidfi,varidfn
95	c therm
96	integer varidfmth,varidenth
97	integer varidyu1,varidyv1,varidpl,varidai,varididvt
98	integer varidfts1,varidfts2,varidfts3,varidfts4
99	integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
100	save varidmfu, varidmfd, varidps, varidenu, variddeu
101	save varidt
102	save varidend,varidded,varidch,varidfi,varidfn
103	c therm
104	save varidfmth,varidenth
105	save varidyu1,varidyv1,varidpl,varidai,varididvt
106	save varidfts1,varidfts2,varidfts3,varidfts4
107	save varidpsr1,varidpsr2,varidpsr3,varidpsr4
108
109	integer l, i
110	integer start(4),count(4),status
111	real rcode
112	logical first
113	save first
114	data first/.true./
115
116
117
118	c ---------------------------------------------
119	c Initialisation de la lecture des fichiers
120	c ---------------------------------------------
121
122	if (irec .eq. 0) then
123
124	rcode=nf90_open('phystoke.nc',nf90_nowrite,ncidp)
125
126	rcode = nf90_inq_varid(ncidp, 'phis', varidps)
127	print*,'ncidp,varidps',ncidp,varidps
128
129	rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl)
130	print*,'ncidp,varidpl',ncidp,varidpl
131
132	rcode = nf90_inq_varid(ncidp, 'aire', varidai)
133	print*,'ncidp,varidai',ncidp,varidai
134
135	rcode = nf90_inq_varid(ncidp, 't', varidt)
136	print*,'ncidp,varidt',ncidp,varidt
137
138	rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu)
139	print*,'ncidp,varidmfu',ncidp,varidmfu
140
141	rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd)
142	print*,'ncidp,varidmfd',ncidp,varidmfd
143
144	rcode = nf90_inq_varid(ncidp, 'en_u', varidenu)
145	print*,'ncidp,varidenu',ncidp,varidenu
146
147	rcode = nf90_inq_varid(ncidp, 'de_u', variddeu)
148	print*,'ncidp,variddeu',ncidp,variddeu
149
150	rcode = nf90_inq_varid(ncidp, 'en_d', varidend)
151	print*,'ncidp,varidend',ncidp,varidend
152
153	rcode = nf90_inq_varid(ncidp, 'de_d', varidded)
154	print*,'ncidp,varidded',ncidp,varidded
155
156	rcode = nf90_inq_varid(ncidp, 'coefh', varidch)
157	print*,'ncidp,varidch',ncidp,varidch
158
159	c Thermiques
160	rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth)
161	print*,'ncidp,varidfmth',ncidp,varidfmth
162
163	rcode = nf90_inq_varid(ncidp, 'en_th', varidenth)
164	print*,'ncidp,varidenth',ncidp,varidenth
165
166	rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi)
167	print*,'ncidp,varidfi',ncidp,varidfi
168
169	rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn)
170	print*,'ncidp,varidfn',ncidp,varidfn
171
172	rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1)
173	print*,'ncidp,varidyu1',ncidp,varidyu1
174
175	rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1)
176	print*,'ncidp,varidyv1',ncidp,varidyv1
177
178	rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1)
179	print*,'ncidp,varidfts1',ncidp,varidfts1
180
181	rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2)
182	print*,'ncidp,varidfts2',ncidp,varidfts2
183
184	rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3)
185	print*,'ncidp,varidfts3',ncidp,varidfts3
186
187	rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4)
188	print*,'ncidp,varidfts4',ncidp,varidfts4
189
190	rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1)
191	print*,'ncidp,varidpsr1',ncidp,varidpsr1
192
193	rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2)
194	print*,'ncidp,varidpsr2',ncidp,varidpsr2
195
196	rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3)
197	print*,'ncidp,varidpsr3',ncidp,varidpsr3
198
199	rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4)
200	print*,'ncidp,varidpsr4',ncidp,varidpsr4
201
202	c ID pour les dimensions
203
204	status = nf_inq_dimid(ncidp,'y',yid)
205	status = nf_inq_dimid(ncidp,'x',xid)
206	status = nf_inq_dimid(ncidp,'sig_s',zid)
207	status = nf_inq_dimid(ncidp,'time_counter',tid)
208
209	c lecture des dimensions
210
211	status = nf_inq_dim(ncidp,yid,namedim,ncjm)
212	status = nf_inq_dim(ncidp,xid,namedim,ncim)
213	status = nf_inq_dim(ncidp,zid,namedim,nckev)
214	status = nf_inq_dim(ncidp,tid,namedim,ncrec)
215
216	zrec=ncrec
217	zkev=nckev
218	zim=ncim
219	zjm=ncjm
220
221	zkon=zim*(zjm-2)+2
222
223	write(,) 'read_pstoke : zrec = ', zrec
224	write(,) 'read_pstoke : kev = ', zkev
225	write(,) 'read_pstoke : zim = ', zim
226	write(,) 'read_pstoke : zjm = ', zjm
227	write(,) 'read_pstoke : kon = ', zkon
228
229	c niveaux de pression
230
231	status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl)
232
233	c lecture de aire et phis
234
235	start(1)=1
236	start(2)=1
237	start(3)=1
238	start(4)=0
239
240	count(1)=zim
241	count(2)=zjm
242	count(3)=1
243	count(4)=0
244
245	c
246	C** Geopotentiel au sol *************************************
247	c phis
248	#ifdef NC_DOUBLE
249	status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
250	#else
251	status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
252	#endif
253	call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi)
254
255	C** Aires des mails aux sol **********************************
256	c aire
257	#ifdef NC_DOUBLE
258	status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
259	#else
260	status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
261	#endif
262	call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi)
263	else
264
265	print*,'ok1'
266
267	c ---------------------
268	c lecture des champs
269	c ---------------------
270
271	print*,'WARNING!!! Il n y a pas de test de coherence'
272	print*,'sur le nombre de niveaux verticaux dans le fichier nc'
273
274	start(1)=1
275	start(2)=1
276	start(3)=1
277	start(4)=irec
278
279	count(1)=zim
280	count(2)=zjm
281	count(3)=kev
282	count(4)=1
283
284	C** Temperature ******************************************
285	cA FAIRE : Es-ce necessaire ?
286
287	c abder t
288	#ifdef NC_DOUBLE
289	status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
290	#else
291	status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
292	#endif
293	call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t)
294
295	C** Flux pour la convection (Tiedtk) ******************************************
296	c mfu
297	#ifdef NC_DOUBLE
298	status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
299	#else
300	status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
301	#endif
302	call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu)
303
304	c mfd
305	#ifdef NC_DOUBLE
306	status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
307	#else
308	status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
309	#endif
310	call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd)
311
312	c en_u
313	#ifdef NC_DOUBLE
314	status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
315	#else
316	status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
317	#endif
318	call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u)
319
320	c de_u
321	#ifdef NC_DOUBLE
322	status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
323	#else
324	status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
325	#endif
326	call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u)
327
328	c en_d
329	#ifdef NC_DOUBLE
330	status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
331	#else
332	status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
333	#endif
334	call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d)
335
336	c de_d
337	#ifdef NC_DOUBLE
338	status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
339	#else
340	status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
341	#endif
342	call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d)
343
344	C** Coefficient de mellange turbulent *****************************************
345	c coefh
346	print*,'LECTURE de coefh a irec =',irec
347	#ifdef NC_DOUBLE
348	status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
349	#else
350	status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
351	#endif
352	call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh)
353	c call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ ')
354	c call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ ')
355
356	C** Flux ascendants et entrant dans le thermique ********************************
357	cThermiques
358	print*,'LECTURE de fm_therm a irec =',irec
359	#ifdef NC_DOUBLE
360	status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,
361	. count,fm_therm2)
362	#else
363	status=NF_GET_VARA_REAL(ncidp,varidfmth,start,
364	. count,fm_therm2)
365	#endif
366	call gr_ecrit_fi(kev,kon,iim,jjm+1,fm_therm2,fm_therm)
367	print*,'LECTURE de en_therm a irec =',irec
368	#ifdef NC_DOUBLE
369	status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,
370	. count,en_therm2)
371	#else
372	status=NF_GET_VARA_REAL(ncidp,varidenth,start,
373	. count,en_therm2)
374	#endif
375	call gr_ecrit_fi(kev,kon,iim,jjm+1,en_therm2,en_therm)
376
377	C** Coefficients de lessivage *****************************************
378	c frac_impa
379	#ifdef NC_DOUBLE
380	status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
381	#else
382	status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
383	#endif
384	call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
385
386	c frac_nucl
387
388	#ifdef NC_DOUBLE
389	status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
390	#else
391	status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
392	#endif
393	call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
394
395	C** Vents aux sol ******************************************
396
397	start(3)=irec
398	start(4)=0
399	count(3)=1
400	count(4)=0
401
402	c pyu1
403	print*,'LECTURE de yu1 a irec =',irec
404	#ifdef NC_DOUBLE
405	status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
406	#else
407	status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
408	#endif
409	call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1)
410
411	c pyv1
412	print*,'LECTURE de yv1 a irec =',irec
413	#ifdef NC_DOUBLE
414	status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
415	#else
416	status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
417	#endif
418	call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1)
419
420	C** Temerature au sol ******************************************
421	c ftsol1
422	print*,'LECTURE de ftsol1 a irec =',irec
423	#ifdef NC_DOUBLE
424	status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
425	#else
426	status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
427	#endif
428	call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1)
429
430	c ftsol2
431	print*,'LECTURE de ftsol2 a irec =',irec
432	#ifdef NC_DOUBLE
433	status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
434	#else
435	status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
436	#endif
437	call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2)
438
439	c ftsol3
440	print*,'LECTURE de ftsol3 a irec =',irec
441	#ifdef NC_DOUBLE
442	status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
443	#else
444	status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
445	#endif
446	call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3)
447
448	c ftsol4
449	#ifdef NC_DOUBLE
450	status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
451	#else
452	status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
453	#endif
454	call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4)
455
456	C** Nature sol ******************************************
457	c psrf1
458	#ifdef NC_DOUBLE
459	status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
460	#else
461	status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
462	#endif
463	c call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
464	call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1)
465
466	c psrf2
467	#ifdef NC_DOUBLE
468	status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
469	#else
470	status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
471	#endif
472	c call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
473	call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2)
474
475	c psrf3
476	#ifdef NC_DOUBLE
477	status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
478	#else
479	status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
480	#endif
481	call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3)
482
483	c psrf4
484	#ifdef NC_DOUBLE
485	status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
486	#else
487	status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
488	#endif
489	call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4)
490
491	do i = 1,kon
492
493	psrf(i,1) = psrf1(i)
494	psrf(i,2) = psrf2(i)
495	psrf(i,3) = psrf3(i)
496	c test abderr
497	c print*,'Dans read_pstoke psrf3 =',psrf3(i),i
498	psrf(i,4) = psrf4(i)
499
500	ftsol(i,1) = ftsol1(i)
501	ftsol(i,2) = ftsol2(i)
502	ftsol(i,3) = ftsol3(i)
503	ftsol(i,4) = ftsol4(i)
504
505	enddo
506
507	endif
508
509	return
510
511	end
512

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

Download in other formats:

Original Format