Context Navigation

read_pstoke0.F @ 1134

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

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

Download in other formats:

Original Format