Context Navigation

read_pstoke.F @ 2440

Last change on this file since 2440 was 1299, checked in by Laurent Fairhead, 15 years ago

Nettoyage general pour se rapprocher des normes et éviter des erreurs a la
compilation:

tous les FLOAT() sont remplacés par des REAL()
tous les STOP dans phylmd sont remplacés par des appels à abort_gcm
le common control défini dans le fichier control.h est remplacé par le module control_mod pour éviter des messages sur l'alignement des variables dans les déclarations
des $Header$ remplacés par des $Id$ pour svn

Quelques remplacements à faire ont pu m'échapper

General cleanup of the code to try and adhere to norms and to prevent some
compilation errors:

all FLOAT() instructions have been replaced by REAL() instructions
all STOP instructions in phylmd have been replaced by calls to abort_gcm
the common block control defined in the control.h file has been replaced by the control_mod to prevent compilation warnings on the alignement of declared variables
$Header$ replaced by $Id$ for svn

Some changes which should have been made might have escaped me

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

File size: 14.5 KB

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

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

Download in other formats:

Original Format