source: LMDZ.3.3/trunk/libf/phylmd/read_pstoke.F @ 481

Last change on this file since 481 was 256, checked in by lmdz, 23 years ago

Recuperation de la version qui se trouvait dans dyn3d et remise des NC_DOUBLE
pour VPP. MAF
LF

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