Context Navigation

read_pstoke0.F @ 985

Last change on this file since 985 was 868, checked in by Laurent Fairhead, 17 years ago
Preparation du remplacement de la physique utilisee pour l'exercice IPCC_AR4 par la version de la physique avec thermique. On garde le repertoire phylmd pour un petit moment pour que les utilisateurs ne soient pas trop perdus ... phy_IPCC_AR4 = phylmd LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 14.7 KB

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

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

Download in other formats:

Original Format