source: LMDZ4/branches/LMDZ4V5.0-LF/libf/phylmd/read_pstoke0.F @ 5360

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