source: LMDZ4/branches/LMDZ4V5.0-dev/libf/phylmd/read_pstoke.F @ 1349

Last change on this file since 1349 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 musat $
3!
4c
5c
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
12C******************************************************************************
13C  Frederic HOURDIN, Abderrahmane IDELKADI
14C Lecture des parametres physique stockes online necessaires pour
15C recalculer offline le transport de traceurs sur une grille 2x plus fine que
16C celle online
17C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
18C******************************************************************************
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"
37cccc#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
67c  !! attention !!
68c attention il y a aussi le pb de def klono
69c 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
114c ---------------------------------------------
115c   Initialisation de la lecture des fichiers
116c ---------------------------------------------
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
131c 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       
156c 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       
199c 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
206c 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
226c 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
233c 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
245c 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
253c 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
264c ---------------------
265c   lecture des champs
266c ---------------------
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
282C *** Lessivage******************************************************
283c 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
291c 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
299C*** Temperature ******************************************************
300c 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
308C*** Flux pour le calcul de la convection TIEDTK ***********************
309c 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
317c 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
325c 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
333c 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
341c 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
349c 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
357C **** Coeffecient du mellange turbulent**********************************
358c 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
366C*** Flux ascendant et entrant pour les Thermiques************************
367cabder 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
382C*** Vitesses aux sol ******************************************************
383      start(3)=irec
384      start(4)=0
385      count(3)=1
386      count(4)=0
387c 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
395c 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
403C*** Temperature au sol ********************************************
404c 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
412c 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
420c 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
428c 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
436C*** Nature du sol **************************************************
437c 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
445c 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
453c 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
461c 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.