My Project
 All Classes Files Functions Variables Macros
read_pstoke.F
Go to the documentation of this file.
1 !
2 ! $Id: read_pstoke.F 1403 2010-07-01 09:02:53Z fairhead $
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